Getting the hostname and the port in config file

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" $ ""