aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/Conf.hs27
-rw-r--r--src/server/Config.hs34
-rw-r--r--src/server/Controller/Index.hs8
-rw-r--r--src/server/Controller/Payment.hs1
-rw-r--r--src/server/Controller/SignIn.hs26
-rw-r--r--src/server/Design/Constants.hs4
-rw-r--r--src/server/Design/SignIn.hs2
-rw-r--r--src/server/Json.hs2
-rw-r--r--src/server/Main.hs16
-rw-r--r--src/server/Model/Json/Conf.hs (renamed from src/server/Model/Json/Config.hs)10
-rw-r--r--src/server/Model/Message.hs7
-rw-r--r--src/server/Model/Payment.hs1
-rw-r--r--src/server/Model/SignIn.hs6
-rw-r--r--src/server/Secure.hs6
-rw-r--r--src/server/SendMail.hs10
-rw-r--r--src/server/Validation.hs6
-rw-r--r--src/server/View/Page.hs8
17 files changed, 82 insertions, 92 deletions
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/Config.hs b/src/server/Model/Json/Conf.hs
index 422ecee..a66fb55 100644
--- a/src/server/Model/Json/Config.hs
+++ b/src/server/Model/Json/Conf.hs
@@ -1,7 +1,7 @@
{-# LANGUAGE DeriveGeneric #-}
-module Model.Json.Config
- ( Config(..)
+module Model.Json.Conf
+ ( Conf(..)
) where
import GHC.Generics
@@ -9,9 +9,9 @@ import GHC.Generics
import Data.Aeson
import Data.Text
-data Config = Config
+data Conf = Conf
{ currency :: Text
} deriving (Show, Generic)
-instance FromJSON Config
-instance ToJSON Config
+instance FromJSON Conf
+instance ToJSON Conf
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"
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 21:48:10 +0000