diff options
Diffstat (limited to 'src')
25 files changed, 107 insertions, 122 deletions
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/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" |