aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/Application.hs19
-rw-r--r--src/server/Config.hs31
-rw-r--r--src/server/Main.hs85
-rw-r--r--src/server/View/Page.hs10
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" $ ""