diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/server/Application.hs | 19 | ||||
| -rw-r--r-- | src/server/Config.hs | 31 | ||||
| -rw-r--r-- | src/server/Main.hs | 85 | ||||
| -rw-r--r-- | src/server/View/Page.hs | 10 |
4 files changed, 92 insertions, 53 deletions
diff --git a/src/server/Application.hs b/src/server/Application.hs index 59aa252..5306e17 100644 --- a/src/server/Application.hs +++ b/src/server/Application.hs @@ -17,7 +17,6 @@ module Application import Web.Scotty import Network.HTTP.Types.Status (ok200, badRequest400) -import Network.Wai (requestHeaderHost) import Database.Persist @@ -29,6 +28,7 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Encoding as TE import Data.String (fromString) import Data.Time.Clock (getCurrentTime, diffUTCTime) +import Data.Maybe (isJust) import Text.Email.Validate (isValid) @@ -42,20 +42,21 @@ import Model.Payment import Model.SignIn import Model.Message +import Config + import View.Page (page) import Mail -signInAction :: Text -> ActionM () -signInAction login = +signInAction :: Config -> Text -> ActionM () +signInAction config login = if isValid (TE.encodeUtf8 login) then do maybeUser <- liftIO . runDb $ getUser login - maybeHost <- fmap TE.decodeUtf8 . requestHeaderHost <$> request - case (maybeUser, maybeHost) of - (Just _, Just host) -> do + if isJust maybeUser + then do token <- liftIO . runDb $ createSignInToken login - let url = T.concat ["http://", host ,"/validateSignIn?token=", token] + let url = T.concat ["http://", hostname config, "/validateSignIn?token=", token] let mail = Mail [login] "Sign in" url url maybeSentMail <- liftIO . sendMail $ mail case maybeSentMail of @@ -63,8 +64,8 @@ signInAction login = status ok200 Left _ -> errorResponse "Sorry, we failed to send you the sign up email." - _ -> - errorResponse "You are not authorized to sign in." + else + errorResponse "You are not authorized to sign in." else errorResponse "Please enter a valid email address." diff --git a/src/server/Config.hs b/src/server/Config.hs new file mode 100644 index 0000000..f4144f7 --- /dev/null +++ b/src/server/Config.hs @@ -0,0 +1,31 @@ +{-# 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) +import Control.Applicative (liftA2) + +data Config = Config + { hostname :: Text + , port :: Int + } deriving (Read, Eq, Show) + +getConfig :: FilePath -> IO (Either String Config) +getConfig filePath = + left show <$> (runErrorT $ do + cp <- join $ liftIO $ readfile emptyCP filePath + liftA2 + Config + (T.pack <$> get cp "DEFAULT" "hostname") + (get cp "DEFAULT" "port") + ) diff --git a/src/server/Main.hs b/src/server/Main.hs index 2ae319b..3033f58 100644 --- a/src/server/Main.hs +++ b/src/server/Main.hs @@ -10,44 +10,51 @@ import Application import Model.Database (runMigrations) +import Config + main :: IO () main = do - runMigrations - scotty 3000 $ do - - middleware $ - staticPolicy (noDots >-> addBase "public") - - get "/" $ - getIndexAction - - post "/signIn" $ do - login <- param "login" :: ActionM Text - signInAction login - - get "/validateSignIn" $ do - token <- param "token" :: ActionM Text - validateSignInAction token - - get "/userName" $ - getUserName - - get "/payments" $ - getPaymentsAction - - post "/payment/add" $ do - name <- param "name" :: ActionM Text - cost <- param "cost" :: ActionM Int - createPaymentAction name cost - - post "/signOut" $ - signOutAction - - get "/users" getUsersAction - post "/user/add" $ do - email <- param "email" :: ActionM Text - name <- param "name" :: ActionM Text - addUserAction email name - post "/user/delete" $ do - email <- param "email" :: ActionM Text - deleteUserAction email + config <- getConfig "config.txt" + case config of + Left error -> + putStrLn error + Right config -> do + runMigrations + scotty (port config) $ do + + middleware $ + staticPolicy (noDots >-> addBase "public") + + get "/" $ + getIndexAction + + post "/signIn" $ do + login <- param "login" :: ActionM Text + signInAction config login + + get "/validateSignIn" $ do + token <- param "token" :: ActionM Text + validateSignInAction token + + get "/userName" $ + getUserName + + get "/payments" $ + getPaymentsAction + + post "/payment/add" $ do + name <- param "name" :: ActionM Text + cost <- param "cost" :: ActionM Int + createPaymentAction name cost + + post "/signOut" $ + signOutAction + + get "/users" getUsersAction + post "/user/add" $ do + email <- param "email" :: ActionM Text + name <- param "name" :: ActionM Text + addUserAction email name + post "/user/delete" $ do + email <- param "email" :: ActionM Text + deleteUserAction email diff --git a/src/server/View/Page.hs b/src/server/View/Page.hs index b5a80e2..a397a96 100644 --- a/src/server/View/Page.hs +++ b/src/server/View/Page.hs @@ -20,10 +20,10 @@ page = H.head $ do meta ! charset "UTF-8" H.title "Shared Cost" - script ! src "/javascripts/client.js" $ "" - link ! rel "stylesheet" ! type_ "text/css" ! href "/css/reset.css" - link ! rel "stylesheet" ! href "/css/font-awesome/css/font-awesome.min.css" - link ! rel "icon" ! type_ "image/png" ! href "/images/icon.png" + script ! src "javascripts/client.js" $ "" + link ! rel "stylesheet" ! type_ "text/css" ! href "css/reset.css" + link ! rel "stylesheet" ! href "css/font-awesome/css/font-awesome.min.css" + link ! rel "icon" ! type_ "image/png" ! href "images/icon.png" H.style $ toHtml globalDesign body $ - script ! src "/javascripts/elmLauncher.js" $ "" + script ! src "javascripts/elmLauncher.js" $ "" |