From 1c7d6ea6e3bcd3c672cb5eb3cf22ffc88cabb257 Mon Sep 17 00:00:00 2001
From: Joris
Date: Sun, 20 Mar 2016 22:38:44 +0100
Subject: use config-manager instead of ConfigFile

---
 src/server/Conf.hs               | 27 +++++++++++++++++++++++++++
 src/server/Config.hs             | 34 ----------------------------------
 src/server/Controller/Index.hs   |  8 ++++----
 src/server/Controller/Payment.hs |  1 -
 src/server/Controller/SignIn.hs  | 26 +++++++++++++-------------
 src/server/Design/Constants.hs   |  4 ++--
 src/server/Design/SignIn.hs      |  2 +-
 src/server/Json.hs               |  2 --
 src/server/Main.hs               | 16 ++++++++--------
 src/server/Model/Json/Conf.hs    | 17 +++++++++++++++++
 src/server/Model/Json/Config.hs  | 17 -----------------
 src/server/Model/Message.hs      |  7 +++++--
 src/server/Model/Payment.hs      |  1 -
 src/server/Model/SignIn.hs       |  6 +++---
 src/server/Secure.hs             |  6 ++----
 src/server/SendMail.hs           | 10 +++++-----
 src/server/Validation.hs         |  6 +++---
 src/server/View/Page.hs          |  8 ++++----
 18 files changed, 94 insertions(+), 104 deletions(-)
 create mode 100644 src/server/Conf.hs
 delete mode 100644 src/server/Config.hs
 create mode 100644 src/server/Model/Json/Conf.hs
 delete mode 100644 src/server/Model/Json/Config.hs

(limited to 'src/server')

diff --git a/src/server/Conf.hs b/src/server/Conf.hs
new file mode 100644
index 0000000..f66eb5e
--- /dev/null
+++ b/src/server/Conf.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Conf
+  ( getConf
+  , Conf(..)
+  ) where
+
+import Data.Text (Text)
+import qualified Data.ConfigManager as Conf
+
+data Conf = Conf
+  { hostname :: Text
+  , port :: Int
+  , signInExpirationMn :: Int
+  , currency :: Text
+  } deriving (Read, Eq, Show)
+
+getConf :: FilePath -> IO (Either Text Conf)
+getConf path =
+  (flip fmap) (Conf.readConfig path) (\configOrError -> do
+    conf <- configOrError
+    Conf <$>
+      Conf.lookup "hostname" conf <*>
+      Conf.lookup "port" conf <*>
+      Conf.lookup "signInExpirationMn" conf <*>
+      Conf.lookup "currency" conf
+  )
diff --git a/src/server/Config.hs b/src/server/Config.hs
deleted file mode 100644
index bd7f325..0000000
--- a/src/server/Config.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts #-}
-
-module Config
-  ( getConfig
-  , Config(..)
-  ) where
-
-import Data.ConfigFile
-import Data.Text (Text)
-import qualified Data.Text as T
-
-import Control.Monad.Trans.Error (runErrorT)
-import Control.Monad.IO.Class (liftIO)
-import Control.Monad (join)
-import Control.Arrow (left)
-
-data Config = Config
-  { hostname :: Text
-  , port :: Int
-  , signInExpirationMn :: Int
-  , currency :: Text
-  } deriving (Read, Eq, Show)
-
-getConfig :: FilePath -> IO (Either Text Config)
-getConfig filePath =
-  left (T.pack . show) <$> (runErrorT $ do
-    cp <- join $ liftIO $ readfile emptyCP filePath
-    Config <$>
-      (T.pack <$> get cp "DEFAULT" "hostname") <*>
-      (get cp "DEFAULT" "port") <*>
-      (get cp "DEFAULT" "sign-in-expiration-mn") <*>
-      (T.pack <$> get cp "DEFAULT" "currency")
-  )
diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs
index e4ec729..db1038a 100644
--- a/src/server/Controller/Index.hs
+++ b/src/server/Controller/Index.hs
@@ -7,15 +7,15 @@ import Web.Scotty
 
 import Network.HTTP.Types.Status (ok200)
 
-import Config (Config(..))
+import Conf (Conf(..))
 import qualified LoginSession
 
-import qualified Model.Json.Config as M
+import qualified Model.Json.Conf as M
 
 import View.Page (page)
 
-getIndex :: Config -> ActionM ()
-getIndex config = html . page $ M.Config { M.currency = currency config }
+getIndex :: Conf -> ActionM ()
+getIndex conf = html . page $ M.Conf { M.currency = currency conf }
 
 signOut :: ActionM ()
 signOut = do
diff --git a/src/server/Controller/Payment.hs b/src/server/Controller/Payment.hs
index 432603b..ec241f7 100644
--- a/src/server/Controller/Payment.hs
+++ b/src/server/Controller/Payment.hs
@@ -29,7 +29,6 @@ import Model.Database
 import qualified Model.Payment as P
 import Model.Frequency
 import Model.Json.Number
-import Model.Message
 import Model.Message.Key (Key(PaymentNotDeleted))
 
 getPayments :: ActionM ()
diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs
index d4a1e25..0153784 100644
--- a/src/server/Controller/SignIn.hs
+++ b/src/server/Controller/SignIn.hs
@@ -22,7 +22,7 @@ import Data.Maybe (isJust)
 
 import qualified LoginSession
 
-import Config
+import Conf
 
 import SendMail
 
@@ -38,15 +38,15 @@ import Secure (getUserFromToken)
 
 import qualified View.Mail.SignIn as SignIn
 
-signIn :: Config -> Text -> ActionM ()
-signIn config login =
+signIn :: Conf -> Text -> ActionM ()
+signIn conf login =
   if Email.isValid (TE.encodeUtf8 login)
     then do
       maybeUser <- liftIO . runDb $ getUser login
       case maybeUser of
         Just user -> do
           token <- liftIO . runDb $ createSignInToken login
-          let url = T.concat ["http://", hostname config, "/validateSignIn?token=", token]
+          let url = T.concat ["http://", hostname conf, "/validateSignIn?token=", token]
           maybeSentMail <- liftIO . sendMail $ SignIn.getMail (entityVal user) url [login]
           case maybeSentMail of
             Right _ ->
@@ -61,28 +61,28 @@ signIn config login =
       status badRequest400
       text . TL.pack . show $ EnterValidEmail
 
-validateSignIn :: Config -> Text -> ActionM ()
-validateSignIn config textToken = do
+validateSignIn :: Conf -> Text -> ActionM ()
+validateSignIn conf textToken = do
   alreadySigned <- isAlreadySigned
   if alreadySigned
     then
       redirect "/"
     else do
-      mbSignIn <- liftIO . runDb $ getSignInToken textToken
+      mbSignIn <- liftIO . runDb $ getSignIn textToken
       now <- liftIO getCurrentTime
       case mbSignIn of
-        Just signIn ->
-          if signInIsUsed . entityVal $ signIn
+        Just signInValue ->
+          if signInIsUsed . entityVal $ signInValue
             then
               redirectError (getMessage SignInUsed)
             else
-              let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signIn)
-              in  if diffTime > (fromIntegral $ (signInExpirationMn config) * 60)
+              let diffTime = now `diffUTCTime` (signInCreation . entityVal $ signInValue)
+              in  if diffTime > (fromIntegral $ (signInExpirationMn conf) * 60)
                     then
                       redirectError (getMessage SignInExpired)
                     else do
-                      LoginSession.put (signInToken . entityVal $ signIn)
-                      liftIO . runDb . signInTokenToUsed . entityKey $ signIn
+                      LoginSession.put (signInToken . entityVal $ signInValue)
+                      liftIO . runDb . signInTokenToUsed . entityKey $ signInValue
                       redirect "/"
         Nothing ->
           redirectError (getMessage SignInInvalid)
diff --git a/src/server/Design/Constants.hs b/src/server/Design/Constants.hs
index 94df14b..3395852 100644
--- a/src/server/Design/Constants.hs
+++ b/src/server/Design/Constants.hs
@@ -27,7 +27,7 @@ inputHeight :: Integer
 inputHeight = 40
 
 focusLighten :: Color -> Color
-focusLighten color = color +. 20
+focusLighten baseColor = baseColor +. 20
 
 focusDarken :: Color -> Color
-focusDarken color = color -. 20
+focusDarken baseColor = baseColor -. 20
diff --git a/src/server/Design/SignIn.hs b/src/server/Design/SignIn.hs
index d2487f1..814cca3 100644
--- a/src/server/Design/SignIn.hs
+++ b/src/server/Design/SignIn.hs
@@ -8,7 +8,7 @@ import Clay
 
 import Design.Color as C
 import Design.Helper
-import Design.Constants
+import Design.Constants (focusLighten)
 
 signInDesign :: Css
 signInDesign =
diff --git a/src/server/Json.hs b/src/server/Json.hs
index 935a9cb..a2f1ef5 100644
--- a/src/server/Json.hs
+++ b/src/server/Json.hs
@@ -6,8 +6,6 @@ module Json
 
 import Web.Scotty
 
-import Network.HTTP.Types.Status (badRequest400)
-
 import qualified Data.Aeson.Types as Json
 import qualified Data.HashMap.Strict as M
 import Data.Text (Text)
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 3ce6e64..998b394 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -20,33 +20,33 @@ import Controller.Payer
 import Model.Database (runMigrations)
 import Model.Frequency
 
-import qualified Config
+import qualified Conf
 
 main :: IO ()
 main = do
   runMigrations
   _ <- forkIO monthlyPaymentJobListener
-  eitherConfig <- Config.getConfig "config.txt"
-  case eitherConfig of
+  confOrError <- Conf.getConf "application.conf"
+  case confOrError of
     Left errorMessage ->
       T.putStrLn errorMessage
-    Right config -> do
-      scotty (Config.port config) $ do
+    Right conf -> do
+      scotty (Conf.port conf) $ do
         middleware $
           staticPolicy (noDots >-> addBase "public")
 
-        get  "/"             (getIndex config)
+        get  "/"             (getIndex conf)
         post "/signOut"      signOut
 
         -- SignIn
 
         post "/signIn" $ do
           email <- param "email" :: ActionM Text
-          signIn config email
+          signIn conf email
 
         get "/validateSignIn" $ do
           token <- param "token" :: ActionM Text
-          validateSignIn config token
+          validateSignIn conf token
 
         -- Users
 
diff --git a/src/server/Model/Json/Conf.hs b/src/server/Model/Json/Conf.hs
new file mode 100644
index 0000000..a66fb55
--- /dev/null
+++ b/src/server/Model/Json/Conf.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Model.Json.Conf
+  ( Conf(..)
+  ) where
+
+import GHC.Generics
+
+import Data.Aeson
+import Data.Text
+
+data Conf = Conf
+  { currency :: Text
+  } deriving (Show, Generic)
+
+instance FromJSON Conf
+instance ToJSON Conf
diff --git a/src/server/Model/Json/Config.hs b/src/server/Model/Json/Config.hs
deleted file mode 100644
index 422ecee..0000000
--- a/src/server/Model/Json/Config.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Json.Config
-  ( Config(..)
-  ) where
-
-import GHC.Generics
-
-import Data.Aeson
-import Data.Text
-
-data Config = Config
-  { currency :: Text
-  } deriving (Show, Generic)
-
-instance FromJSON Config
-instance ToJSON Config
diff --git a/src/server/Model/Message.hs b/src/server/Model/Message.hs
index a65e01c..0e83e5b 100644
--- a/src/server/Model/Message.hs
+++ b/src/server/Model/Message.hs
@@ -18,10 +18,13 @@ getMessage :: Key -> Text
 getMessage = getParamMessage []
 
 getParamMessage :: [Text] -> Key -> Text
-getParamMessage values key = replaceParts values (getNonFormattedMessage lang key)
+getParamMessage values paramKey = replaceParts values (getNonFormattedMessage lang paramKey)
 
 getTranslations :: [Translation]
 getTranslations = (map getTranslation [minBound..])
 
 getTranslation :: Key -> Translation
-getTranslation key = Translation (T.pack . show $ key) (getParts $ getNonFormattedMessage lang key)
+getTranslation translationKey =
+  Translation
+    (T.pack . show $ translationKey)
+    (getParts $ getNonFormattedMessage lang translationKey)
diff --git a/src/server/Model/Payment.hs b/src/server/Model/Payment.hs
index 404b143..9b32fea 100644
--- a/src/server/Model/Payment.hs
+++ b/src/server/Model/Payment.hs
@@ -10,7 +10,6 @@ module Model.Payment
   ) where
 
 import Data.Text (Text)
-import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime)
 import Data.Either (lefts)
 
diff --git a/src/server/Model/SignIn.hs b/src/server/Model/SignIn.hs
index 117b8b5..06aba5a 100644
--- a/src/server/Model/SignIn.hs
+++ b/src/server/Model/SignIn.hs
@@ -1,6 +1,6 @@
 module Model.SignIn
   ( createSignInToken
-  , getSignInToken
+  , getSignIn
   , signInTokenToUsed
   , isLastValidToken
   ) where
@@ -22,8 +22,8 @@ createSignInToken email = do
   _ <- insert $ SignIn token now email False
   return token
 
-getSignInToken :: Text -> Persist (Maybe (Entity SignIn))
-getSignInToken token =
+getSignIn :: Text -> Persist (Maybe (Entity SignIn))
+getSignIn token =
   selectFirst [SignInToken ==. token] []
 
 signInTokenToUsed :: SignInId -> Persist ()
diff --git a/src/server/Secure.hs b/src/server/Secure.hs
index 7b6e6de..f563f23 100644
--- a/src/server/Secure.hs
+++ b/src/server/Secure.hs
@@ -12,14 +12,12 @@ import Network.HTTP.Types.Status (forbidden403)
 import Database.Persist (Entity, entityVal)
 
 import Model.User (getUser)
-import Model.SignIn (getSignInToken)
+import Model.SignIn (getSignIn)
 import Model.Database
 
 import Control.Monad.IO.Class (liftIO)
 
 import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.IO as TIO
 
 import qualified LoginSession
 
@@ -41,7 +39,7 @@ loggedAction action = do
 
 getUserFromToken :: Text -> Persist (Maybe (Entity User))
 getUserFromToken token = do
-  mbSignIn <- fmap entityVal <$> getSignInToken token
+  mbSignIn <- fmap entityVal <$> getSignIn token
   case mbSignIn of
     Just signIn -> do
       getUser (signInEmail signIn)
diff --git a/src/server/SendMail.hs b/src/server/SendMail.hs
index 8f62bb1..7d537fc 100644
--- a/src/server/SendMail.hs
+++ b/src/server/SendMail.hs
@@ -24,12 +24,12 @@ sendMail mail = do
   return result
 
 getMimeMail :: Mail -> M.Mail
-getMimeMail (Mail from to subject plainBody) =
-  let fromMail = M.emptyMail (address from)
+getMimeMail (Mail mailFrom mailTo mailSubject mailPlainBody) =
+  let fromMail = M.emptyMail (address mailFrom)
   in  fromMail
-        { M.mailTo = map address to
-        , M.mailParts = [ [ M.plainPart plainBody ] ]
-        , M.mailHeaders = [("Subject", subject)]
+        { M.mailTo = map address mailTo
+        , M.mailParts = [ [ M.plainPart mailPlainBody ] ]
+        , M.mailHeaders = [("Subject", mailSubject)]
         }
 
 address :: Text -> M.Address
diff --git a/src/server/Validation.hs b/src/server/Validation.hs
index 9035be7..455ae5b 100644
--- a/src/server/Validation.hs
+++ b/src/server/Validation.hs
@@ -15,9 +15,9 @@ nonEmpty x str =
 number :: x -> (Int -> Bool) -> Text -> Either x Int
 number x numberForm str =
   case reads (T.unpack str) :: [(Int, String)] of
-    (number, _) : _ ->
-      if numberForm number
-        then Right number
+    (num, _) : _ ->
+      if numberForm num
+        then Right num
         else Left x
     _ ->
       Left x
diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs
index e85ed33..4fc57f9 100644
--- a/src/server/View/Page.hs
+++ b/src/server/View/Page.hs
@@ -18,11 +18,11 @@ import Text.Blaze.Html.Renderer.Text (renderHtml)
 import Design.Global (globalDesign)
 
 import Model.Message
-import Model.Json.Config
+import Model.Json.Conf
 import Model.Message.Key (Key(SharedCost))
 
-page :: Config -> Text
-page config =
+page :: Conf -> Text
+page conf =
   renderHtml . docTypeHtml $ do
     H.head $ do
       meta ! charset "UTF-8"
@@ -31,7 +31,7 @@ page config =
       script ! src "https://login.persona.org/include.js" $ ""
       script ! src "javascripts/client.js" $ ""
       script ! A.id "messages" ! type_ "application/json" $ toHtml . decodeUtf8 . encode $ getTranslations
-      script ! A.id "config" ! type_ "application/json" $ toHtml . decodeUtf8 . encode $ config
+      script ! A.id "conf" ! type_ "application/json" $ toHtml . decodeUtf8 . encode $ conf
       link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css"
       link ! rel "stylesheet" ! href "css/font-awesome-4.5.0/css/font-awesome.min.css"
       link ! rel "icon" ! type_ "image/png" ! href "images/icon.png"
-- 
cgit v1.2.3