[all] Fix all warnings

This commit is contained in:
Vincent Ambo 2015-11-21 03:18:08 +01:00
parent c2fe73b027
commit 77c376e283
No known key found for this signature in database
GPG key ID: 66F505681DB8F43B
4 changed files with 46 additions and 43 deletions

View file

@ -1,11 +1,8 @@
module Blog where module Blog where
import BlogDB import BlogDB
import Control.Monad (unless, when)
import Data.Data (Data, Typeable)
import Data.List (intersperse) import Data.List (intersperse)
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Data.Monoid (mempty)
import Data.Text (Text, append, empty, pack) import Data.Text (Text, append, empty, pack)
import Data.Text.Lazy (fromStrict) import Data.Text.Lazy (fromStrict)
import Data.Time import Data.Time
@ -60,7 +57,7 @@ $doctype 5
<div .container> <div .container>
^{body} ^{body}
<footer .footer> <footer .footer>
^{showFooter lang $ pack version} ^{showFooter $ pack version}
|] |]
where where
rssUrl = T.concat ["/", show' lang, "/rss.xml"] rssUrl = T.concat ["/", show' lang, "/rss.xml"]
@ -71,8 +68,8 @@ $doctype 5
<a class="link" href=#{twitter} target="_blank">Twitter <a class="link" href=#{twitter} target="_blank">Twitter
|] |]
showFooter :: BlogLang -> Text -> Html showFooter :: Text -> Html
showFooter l v = [shamlet| showFooter v = [shamlet|
<div .container> <div .container>
<div .row> <div .row>
<div .span12 .righttext style="text-align: right;margin-right:-200px"> <div .span12 .righttext style="text-align: right;margin-right:-200px">
@ -271,4 +268,10 @@ showError NotFound l = blogTemplate l (T.append ": " $ notFoundTitle l) $ [shaml
<div .span12 .notFoundText> <div .span12 .notFoundText>
#{notFoundText l} #{notFoundText l}
|] |]
showError UnknownError l = blogTemplate l "" $ [shamlet|
<div .row .text-center>
<div .span12 .notFoundFace>:(
<div .row .text-center>
<div .span12 .notFoundText>
#{unknownErrorText l}
|]

View file

@ -7,11 +7,9 @@ import Data.Acid.Advanced
import Data.Acid.Remote import Data.Acid.Remote
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Data (Data, Typeable) import Data.Data (Data, Typeable)
import Data.IxSet (Indexable (..), IxSet (..), Proxy (..), getOne, ixFun, ixSet, (@=)) import Data.IxSet (Indexable (..), IxSet, Proxy (..), getOne, ixFun, ixSet, (@=))
import Data.List (insert) import Data.SafeCopy (base, deriveSafeCopy)
import Data.SafeCopy (SafeCopy, base, deriveSafeCopy)
import Data.Text (Text, pack) import Data.Text (Text, pack)
import Data.Text.Lazy (toStrict)
import Data.Time import Data.Time
import Network (PortID (..)) import Network (PortID (..))
import System.Environment (getEnv) import System.Environment (getEnv)
@ -20,7 +18,6 @@ import qualified Crypto.Hash.SHA512 as SHA (hash)
import qualified Data.ByteString.Base64 as B64 (encode) import qualified Data.ByteString.Base64 as B64 (encode)
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import qualified Data.IxSet as IxSet import qualified Data.IxSet as IxSet
import qualified Data.Text as Text
newtype EntryId = EntryId { unEntryId :: Integer } newtype EntryId = EntryId { unEntryId :: Integer }
deriving (Eq, Ord, Data, Enum, Typeable) deriving (Eq, Ord, Data, Enum, Typeable)
@ -138,12 +135,12 @@ updateEntry e =
getEntry :: EntryId -> Query Blog (Maybe Entry) getEntry :: EntryId -> Query Blog (Maybe Entry)
getEntry eId = getEntry eId =
do b@Blog{..} <- ask do Blog{..} <- ask
return $ getOne $ blogEntries @= eId return $ getOne $ blogEntries @= eId
latestEntries :: BlogLang -> Query Blog [Entry] latestEntries :: BlogLang -> Query Blog [Entry]
latestEntries lang = latestEntries lang =
do b@Blog{..} <- ask do Blog{..} <- ask
return $ IxSet.toDescList (Proxy :: Proxy EDate) $ blogEntries @= lang return $ IxSet.toDescList (Proxy :: Proxy EDate) $ blogEntries @= lang
addSession :: Session -> Update Blog Session addSession :: Session -> Update Blog Session
@ -154,7 +151,7 @@ addSession nSession =
getSession :: SessionID -> Query Blog (Maybe Session) getSession :: SessionID -> Query Blog (Maybe Session)
getSession sId = getSession sId =
do b@Blog{..} <- ask do Blog{..} <- ask
return $ getOne $ blogSessions @= sId return $ getOne $ blogSessions @= sId
clearSessions :: Update Blog [Session] clearSessions :: Update Blog [Session]
@ -172,12 +169,12 @@ addUser un pw =
getUser :: Username -> Query Blog (Maybe User) getUser :: Username -> Query Blog (Maybe User)
getUser uN = getUser uN =
do b@Blog{..} <- ask do Blog{..} <- ask
return $ getOne $ blogUsers @= uN return $ getOne $ blogUsers @= uN
checkUser :: Username -> String -> Query Blog Bool checkUser :: Username -> String -> Query Blog Bool
checkUser uN pw = checkUser uN pw =
do b@Blog{..} <- ask do Blog{..} <- ask
let user = getOne $ blogUsers @= uN let user = getOne $ blogUsers @= uN
case user of case user of
Nothing -> return False Nothing -> return False

View file

@ -1,7 +1,6 @@
module Locales where module Locales where
import BlogDB (BlogLang (..)) import BlogDB (BlogLang (..))
import Data.Data (Data, Typeable)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
@ -10,7 +9,7 @@ import Network.URI
{- to add a language simply define its abbreviation and Show instance then {- to add a language simply define its abbreviation and Show instance then
- translate the appropriate strings and add CouchDB views in Server.hs -} - translate the appropriate strings and add CouchDB views in Server.hs -}
data BlogError = NotFound | DBError data BlogError = NotFound | UnknownError
version = "5.1-beta" version = "5.1-beta"
@ -37,31 +36,33 @@ getMonth l y m = T.append (monthName l m) $ T.pack $ show y
where where
monthName :: BlogLang -> Int -> Text monthName :: BlogLang -> Int -> Text
monthName DE m = case m of monthName DE m = case m of
1 -> "Januar " 1 -> "Januar "
2 -> "Februar " 2 -> "Februar "
3 -> "März " 3 -> "März "
4 -> "April " 4 -> "April "
5 -> "Mai " 5 -> "Mai "
6 -> "Juni " 6 -> "Juni "
7 -> "Juli " 7 -> "Juli "
8 -> "August " 8 -> "August "
9 -> "September " 9 -> "September "
10 -> "Oktober " 10 -> "Oktober "
11 -> "November " 11 -> "November "
12 -> "Dezember " 12 -> "Dezember "
_ -> "Unbekannt "
monthName EN m = case m of monthName EN m = case m of
1 -> "January " 1 -> "January "
2 -> "February " 2 -> "February "
3 -> "March " 3 -> "March "
4 -> "April " 4 -> "April "
5 -> "May " 5 -> "May "
6 -> "June " 6 -> "June "
7 -> "July " 7 -> "July "
8 -> "August " 8 -> "August "
9 -> "September " 9 -> "September "
10 -> "October " 10 -> "October "
11 -> "November " 11 -> "November "
12 -> "December " 12 -> "December "
_ -> "Unknown "
entireMonth :: BlogLang -> Text entireMonth :: BlogLang -> Text
entireMonth DE = "Ganzer Monat" entireMonth DE = "Ganzer Monat"
@ -118,6 +119,10 @@ notFoundText :: BlogLang -> Text
notFoundText DE = "Das gewünschte Objekt wurde leider nicht gefunden." notFoundText DE = "Das gewünschte Objekt wurde leider nicht gefunden."
notFoundText EN = "The requested object could not be found." notFoundText EN = "The requested object could not be found."
unknownErrorText :: BlogLang -> Text
unknownErrorText DE = "Ein unbekannter Fehler ist aufgetreten."
unknownErrorText EN = "An unknown error has occured."
-- static information -- static information
repoURL :: Text = "http://hg.tazj.in/tazblog-haskell" repoURL :: Text = "http://hg.tazj.in/tazblog-haskell"
mailTo :: Text = "mailto:tazjin+blog@gmail.com" mailTo :: Text = "mailto:tazjin+blog@gmail.com"

View file

@ -2,15 +2,13 @@
module Server where module Server where
import Control.Applicative (optional, pure, (<$>), (<*>)) import Control.Applicative (optional)
import Control.Monad (liftM, msum, mzero, unless, when) import Control.Monad (msum, mzero, unless)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask)
import Data.Acid import Data.Acid
import Data.Acid.Advanced import Data.Acid.Advanced
import Data.ByteString.Char8 (ByteString, pack, unpack) import Data.ByteString.Char8 (unpack)
import Data.Char (toLower) import Data.Char (toLower)
import Data.Maybe (fromJust)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time import Data.Time
@ -136,7 +134,7 @@ postEntry acid = do
timeToId t = EntryId . read $ formatTime defaultTimeLocale "%s" t timeToId t = EntryId . read $ formatTime defaultTimeLocale "%s" t
getLang :: String -> ServerPart BlogLang getLang :: String -> ServerPart BlogLang
getLang "de" = return DE getLang "de" = return DE
getLang "en" = return EN getLang _ = return EN -- English is default
entryList :: AcidState Blog -> BlogLang -> ServerPart Response entryList :: AcidState Blog -> BlogLang -> ServerPart Response
entryList acid lang = do entryList acid lang = do