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/client/elm/Main.elm                     |  4 ++--
 src/client/elm/Model.elm                    | 12 +++++-----
 src/client/elm/Model/Conf.elm               | 13 +++++++++++
 src/client/elm/Model/Config.elm             | 18 ---------------
 src/client/elm/View/LoggedIn/AddPayment.elm |  2 +-
 src/client/elm/View/LoggedIn/Table.elm      |  2 +-
 src/client/elm/View/Price.elm               |  2 +-
 src/client/js/main.js                       |  2 +-
 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 +++----
 26 files changed, 119 insertions(+), 134 deletions(-)
 create mode 100644 src/client/elm/Model/Conf.elm
 delete mode 100644 src/client/elm/Model/Config.elm
 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')

diff --git a/src/client/elm/Main.elm b/src/client/elm/Main.elm
index b4b440b..06b5ec3 100644
--- a/src/client/elm/Main.elm
+++ b/src/client/elm/Main.elm
@@ -26,7 +26,7 @@ main = app.html
 app : App Model
 app = StartApp.start
   { init =
-      ( initialModel initialTime translations config
+      ( initialModel initialTime translations conf
       , Server.init
           |> Task.map GoLoggedInView
           |> flip Task.onError (always <| Task.succeed GoSignInView)
@@ -44,7 +44,7 @@ port tasks = app.tasks
 
 port initialTime : Time
 port translations : String
-port config : String
+port conf : String
 
 -- Output ports
 
diff --git a/src/client/elm/Model.elm b/src/client/elm/Model.elm
index 43a19c5..5dc6692 100644
--- a/src/client/elm/Model.elm
+++ b/src/client/elm/Model.elm
@@ -8,25 +8,25 @@ import Json.Decode as Json
 
 import Model.View exposing (..)
 import Model.Translations exposing (..)
-import Model.Config exposing (..)
+import Model.Conf exposing (..)
 
 type alias Model =
   { view : View
   , currentTime : Time
   , translations : Translations
-  , config : Config
+  , conf : Conf
   }
 
 initialModel : Time -> String -> String -> Model
-initialModel initialTime translationsValue configValue =
+initialModel initialTime translationsValue confValue =
   { view = LoadingView
   , currentTime = initialTime
   , translations =
       case Json.decodeString translationsDecoder translationsValue of
         Ok translations -> translations
         Err err -> []
-  , config =
-      case Json.decodeString configDecoder configValue of
-        Ok config -> config
+  , conf =
+      case Json.decodeString confDecoder confValue of
+        Ok conf -> conf
         Err err -> { currency = "" }
   }
diff --git a/src/client/elm/Model/Conf.elm b/src/client/elm/Model/Conf.elm
new file mode 100644
index 0000000..ad71d83
--- /dev/null
+++ b/src/client/elm/Model/Conf.elm
@@ -0,0 +1,13 @@
+module Model.Conf
+  ( Conf
+  , confDecoder
+  ) where
+
+import Json.Decode exposing (..)
+
+type alias Conf =
+  { currency : String
+  }
+
+confDecoder : Decoder Conf
+confDecoder = object1 Conf ("currency" := string)
diff --git a/src/client/elm/Model/Config.elm b/src/client/elm/Model/Config.elm
deleted file mode 100644
index e47b032..0000000
--- a/src/client/elm/Model/Config.elm
+++ /dev/null
@@ -1,18 +0,0 @@
-module Model.Config
-  ( Config
-  , configDecoder
-  ) where
-
-import Json.Decode exposing (..)
-
-type alias Config =
-  { currency : String
-  }
-
-configDecoder : Decoder Config
-configDecoder = object1 Config ("currency" := string)
-
-defaultConfig : Config
-defaultConfig =
-  { currency = "€"
-  }
diff --git a/src/client/elm/View/LoggedIn/AddPayment.elm b/src/client/elm/View/LoggedIn/AddPayment.elm
index 0149432..7c0d34b 100644
--- a/src/client/elm/View/LoggedIn/AddPayment.elm
+++ b/src/client/elm/View/LoggedIn/AddPayment.elm
@@ -94,7 +94,7 @@ addPaymentCost address model addPayment =
         []
     , label
         [ for "costInput" ]
-        [ text model.config.currency ]
+        [ text model.conf.currency ]
     , case addPayment.costError of
         Just error ->
           div [ class "errorMessage" ] [ text error ]
diff --git a/src/client/elm/View/LoggedIn/Table.elm b/src/client/elm/View/LoggedIn/Table.elm
index ca5680f..4c302a5 100644
--- a/src/client/elm/View/LoggedIn/Table.elm
+++ b/src/client/elm/View/LoggedIn/Table.elm
@@ -34,7 +34,7 @@ headerLine model =
   div
     [ class "header" ]
     [ div [ class "cell category" ] [ renderIcon "shopping-cart" ]
-    , div [ class "cell cost" ] [ text model.config.currency ]
+    , div [ class "cell cost" ] [ text model.conf.currency ]
     , div [ class "cell user" ] [ renderIcon "user" ]
     , div [ class "cell date" ] [ renderIcon "calendar" ]
     , div [ class "cell" ] []
diff --git a/src/client/elm/View/Price.elm b/src/client/elm/View/Price.elm
index 286bcaa..be665a8 100644
--- a/src/client/elm/View/Price.elm
+++ b/src/client/elm/View/Price.elm
@@ -11,7 +11,7 @@ price : Model -> Int -> String
 price model amount =
   (  formatInt amount
   ++ " "
-  ++ model.config.currency
+  ++ model.conf.currency
   )
 
 formatInt : Int -> String
diff --git a/src/client/js/main.js b/src/client/js/main.js
index bdcb479..4c7e2df 100644
--- a/src/client/js/main.js
+++ b/src/client/js/main.js
@@ -2,7 +2,7 @@ Elm.fullscreen(Elm.Main, {
   signInError: getParameterByName('signInError'),
   initialTime: new Date().getTime(),
   translations: document.getElementById('messages').innerHTML,
-  config: document.getElementById('config').innerHTML
+  conf: document.getElementById('conf').innerHTML
 });
 
 function getParameterByName(name) {
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