From 01e4ce0fa7c369996ec4ef3a033d16d6fa0eb715 Mon Sep 17 00:00:00 2001 From: Joris Date: Thu, 31 Mar 2016 18:45:36 +0200 Subject: Use https link and secure cookie when activated --- src/server/Conf.hs | 4 +++- src/server/Controller/Index.hs | 8 +++----- src/server/Controller/SignIn.hs | 10 ++++++++-- src/server/Cookie.hs | 25 ++++++++++++++----------- src/server/LoginSession.hs | 12 +++++++----- src/server/Main.hs | 2 +- 6 files changed, 36 insertions(+), 25 deletions(-) (limited to 'src/server') 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 -- cgit v1.2.3