mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Reinstate some language handling

Browse source
This commit is contained in:
Vincent Ambo 2015-11-20 01:53:38 +01:00
parent c60a856388
commit 1342e8fb1d
3 changed files with 13 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
src/Locales.hs
View file

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

18
src/Server.hs
View file

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

2
tazblog.cabal
View file

@ -1,5 +1,5 @@
Name: tazblog Name: tazblog
Version: 5.0 Version: 5.0.1
Synopsis: Tazjin's Blog Synopsis: Tazjin's Blog
License: MIT License: MIT
License-file: LICENSE License-file: LICENSE