Reinstate some language handling

src/Locales.hs

@@ -5,8 +5,6 @@ import           Data.Maybe  (fromMaybe)
 import           Data.Text   (Text)
 import qualified Data.Text   as T
 import           Network.URI
-
-
 import           BlogDB      (BlogLang (..))
 
 {- to add a language simply define its abbreviation and Show instance then
@@ -14,7 +12,7 @@ import           BlogDB      (BlogLang (..))
 
 data BlogError = NotFound | DBError
 
-version = "5.0"
+version = "5.0.1"
 
 allLang = [EN, DE]
 

src/Server.hs

@@ -21,6 +21,14 @@ import BlogDB  hiding (updateEntry)
 import Locales
 import RSS
 
+
+instance FromReqURI BlogLang where
+  fromReqURI sub =
+    case map toLower sub of
+      "de" -> Just DE
+      "en" -> Just EN
+      _    -> Nothing
+
 tmpPolicy :: BodyPolicy
 tmpPolicy = defaultBodyPolicy "/tmp" 0 200000 1000
 
@@ -31,8 +39,7 @@ runBlog acid port respath =
 tazBlog :: AcidState Blog -> String -> ServerPart Response
 tazBlog acid resDir = do
     msum [ nullDir >> blogHandler acid EN
-         , dir "de" $ blogHandler acid DE
-         , path $ \(year :: Int) -> path $ \(month :: Int) -> path $ \(id_ :: String) -> formatOldLink year month id_
+         , path $ \(lang :: BlogLang) -> blogHandler acid lang
          , dir "notice" $ ok $ toResponse showSiteNotice
          {- :Admin handlers -}
          , do dirs "admin/postentry" nullDir
@@ -62,7 +69,7 @@ tazBlog acid resDir = do
               setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT"
               dir "static" $ serveDirectory DisableBrowsing [] resDir
          , serveDirectory DisableBrowsing [] resDir
-         , notFound $ toResponse $ showError NotFound EN
+         , notFound $ toResponse $ showError NotFound DE
          ]
 
 blogHandler :: AcidState Blog -> BlogLang -> ServerPart Response
@@ -74,11 +81,6 @@ blogHandler acid lang =
          , notFound $ toResponse $ showError NotFound lang
          ]
 
-formatOldLink :: Int -> Int -> String -> ServerPart Response
-formatOldLink y m id_ =
-  flip seeOther (toResponse ()) $
-    concat $ intersperse' "/"  ["de", show y, show m, replace '.' '/' id_]
-
 showEntry :: AcidState Blog -> BlogLang -> EntryId -> ServerPart Response
 showEntry acid lang eId = do
     entry <- query' acid (GetEntry eId)

tazblog.cabal

@@ -1,5 +1,5 @@
 Name:                tazblog
-Version:             5.0
+Version:             5.0.1
 Synopsis:            Tazjin's Blog
 License:             MIT
 License-file:        LICENSE
@@ -11,7 +11,7 @@ cabal-version:       >= 1.10
 
 library
   hs-source-dirs: src
-  default-language:    Haskell2010
+  default-language: Haskell2010
   exposed-modules: Blog, BlogDB, Locales, Server, RSS
   build-depends: base,
                  bytestring,