aboutsummaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/Conf.hs4
-rw-r--r--src/server/Controller/Index.hs8
-rw-r--r--src/server/Controller/SignIn.hs10
-rw-r--r--src/server/Cookie.hs25
-rw-r--r--src/server/LoginSession.hs12
-rw-r--r--src/server/Main.hs2
6 files changed, 36 insertions, 25 deletions
diff --git a/src/server/Conf.hs b/src/server/Conf.hs
index 14da50f..13d5981 100644
--- a/src/server/Conf.hs
+++ b/src/server/Conf.hs
@@ -15,6 +15,7 @@ data Conf = Conf
, signInExpiration :: NominalDiffTime
, currency :: Text
, noReplyMail :: Text
+ , https :: Bool
} deriving Show
getConf :: FilePath -> IO (Either Text Conf)
@@ -26,5 +27,6 @@ getConf path =
Conf.lookup "port" conf <*>
Conf.lookup "signInExpiration" conf <*>
Conf.lookup "currency" conf <*>
- Conf.lookup "noReplyMail" conf
+ Conf.lookup "noReplyMail" conf <*>
+ Conf.lookup "https" conf
)
diff --git a/src/server/Controller/Index.hs b/src/server/Controller/Index.hs
index f84f945..1e1f942 100644
--- a/src/server/Controller/Index.hs
+++ b/src/server/Controller/Index.hs
@@ -69,7 +69,7 @@ validateSignIn conf textToken = do
then
return . Left $ SignInExpired
else do
- LoginSession.put (signInToken . entityVal $ signInValue)
+ LoginSession.put conf (signInToken . entityVal $ signInValue)
mbUser <- liftIO . runDb $ do
signInTokenToUsed . entityKey $ signInValue
getUser . signInEmail . entityVal $ signInValue
@@ -86,7 +86,5 @@ getLoggedUser = do
Just token -> do
liftIO . runDb . getUserFromToken $ token
-signOut :: ActionM ()
-signOut = do
- LoginSession.delete
- status ok200
+signOut :: Conf -> ActionM ()
+signOut conf = LoginSession.delete conf >> status ok200
diff --git a/src/server/Controller/SignIn.hs b/src/server/Controller/SignIn.hs
index f6804e1..0fbe7c5 100644
--- a/src/server/Controller/SignIn.hs
+++ b/src/server/Controller/SignIn.hs
@@ -17,7 +17,8 @@ import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Encoding as TE
-import Conf
+import Conf (Conf)
+import qualified Conf
import SendMail
@@ -38,7 +39,12 @@ signIn conf login =
case maybeUser of
Just user -> do
token <- liftIO . runDb $ createSignInToken login
- let url = T.concat ["http://", hostname conf, "?signInToken=", token]
+ let url = T.concat [
+ if Conf.https conf then "https://" else "http://",
+ Conf.hostname conf,
+ "?signInToken=",
+ token
+ ]
maybeSentMail <- liftIO . sendMail $ SignIn.getMail conf (entityVal user) url [login]
case maybeSentMail of
Right _ ->
diff --git a/src/server/Cookie.hs b/src/server/Cookie.hs
index 7ff5493..1495fc1 100644
--- a/src/server/Cookie.hs
+++ b/src/server/Cookie.hs
@@ -15,6 +15,9 @@ import qualified Data.Text as TS
import qualified Data.Text.Encoding as TS
import qualified Data.Text.Lazy.Encoding as TL
+import Conf (Conf)
+import qualified Conf
+
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as BSL
@@ -26,28 +29,28 @@ import Blaze.ByteString.Builder ( toLazyByteString )
import Web.Scotty.Trans
import Web.Cookie
-makeSimpleCookie :: TS.Text -> TS.Text -> SetCookie
-makeSimpleCookie n v =
+makeSimpleCookie :: Conf -> TS.Text -> TS.Text -> SetCookie
+makeSimpleCookie conf name value =
def
- { setCookieName = TS.encodeUtf8 n
- , setCookieValue = TS.encodeUtf8 v
+ { setCookieName = TS.encodeUtf8 name
+ , setCookieValue = TS.encodeUtf8 value
, setCookiePath = Just $ TS.encodeUtf8 "/"
- , setCookieSecure = True
+ , setCookieSecure = Conf.https conf
}
setCookie :: (Monad m, ScottyError e) => SetCookie -> ActionT e m ()
-setCookie c = addHeader "Set-Cookie" (TL.decodeUtf8 . toLazyByteString $ renderSetCookie c)
+setCookie name = addHeader "Set-Cookie" (TL.decodeUtf8 . toLazyByteString $ renderSetCookie name)
-setSimpleCookie :: (Monad m, ScottyError e) => TS.Text -> TS.Text -> ActionT e m ()
-setSimpleCookie n v = setCookie $ makeSimpleCookie n v
+setSimpleCookie :: (Monad m, ScottyError e) => Conf -> TS.Text -> TS.Text -> ActionT e m ()
+setSimpleCookie conf name value = setCookie $ makeSimpleCookie conf name value
getCookie :: (Monad m, ScottyError e) => TS.Text -> ActionT e m (Maybe TS.Text)
-getCookie c = liftM (Map.lookup c) getCookies
+getCookie name = liftM (Map.lookup name) getCookies
getCookies :: (Monad m, ScottyError e) => ActionT e m (Map.Map TS.Text TS.Text)
getCookies =
liftM (Map.fromList . maybe [] parse) $ header "Cookie"
where parse = parseCookiesText . BSL.toStrict . TL.encodeUtf8
-deleteCookie :: (Monad m, ScottyError e) => TS.Text -> ActionT e m ()
-deleteCookie c = setCookie $ (makeSimpleCookie c "") { setCookieExpires = Just $ posixSecondsToUTCTime 0 }
+deleteCookie :: (Monad m, ScottyError e) => Conf -> TS.Text -> ActionT e m ()
+deleteCookie conf name = setCookie $ (makeSimpleCookie conf name "") { setCookieExpires = Just $ posixSecondsToUTCTime 0 }
diff --git a/src/server/LoginSession.hs b/src/server/LoginSession.hs
index 3897b4c..6f6d620 100644
--- a/src/server/LoginSession.hs
+++ b/src/server/LoginSession.hs
@@ -15,16 +15,18 @@ import Control.Monad.IO.Class (liftIO)
import Data.Text (Text)
import qualified Data.Text.Encoding as TE
+import Conf (Conf)
+
sessionName :: Text
sessionName = "SESSION"
sessionKeyFile :: FilePath
sessionKeyFile = "sessionKey"
-put :: Text -> ActionM ()
-put value = do
+put :: Conf -> Text -> ActionM ()
+put conf value = do
encrypted <- liftIO $ encrypt value
- setSimpleCookie sessionName encrypted
+ setSimpleCookie conf sessionName encrypted
encrypt :: Text -> IO Text
encrypt value = do
@@ -47,5 +49,5 @@ decrypt encrypted = do
let decrypted = TE.decodeUtf8 <$> CS.decrypt key (TE.encodeUtf8 encrypted)
return decrypted
-delete :: ActionM ()
-delete = deleteCookie sessionName
+delete :: Conf -> ActionM ()
+delete conf = deleteCookie conf sessionName
diff --git a/src/server/Main.hs b/src/server/Main.hs
index 387f782..c6e930a 100644
--- a/src/server/Main.hs
+++ b/src/server/Main.hs
@@ -57,7 +57,7 @@ api conf = do
email <- param "email" :: ActionM Text
signIn conf email
- post "/api/signOut" signOut
+ post "/api/signOut" (signOut conf)
-- Users