Use a better project structure

1 files changed, 56 insertions, 0 deletions

diff --git a/server/src/Cookie.hs b/server/src/Cookie.hs
new file mode 100644
index 0000000..96d45da
--- /dev/null
+++ b/server/src/Cookie.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Cookie
+  ( makeSimpleCookie
+  , setCookie
+  , setSimpleCookie
+  , getCookie
+  , getCookies
+  , deleteCookie
+  ) where
+
+import Control.Monad ( liftM )
+
+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
+
+import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
+
+import Blaze.ByteString.Builder ( toLazyByteString )
+
+import Web.Scotty.Trans
+import Web.Cookie
+
+makeSimpleCookie :: Conf -> TS.Text -> TS.Text -> SetCookie
+makeSimpleCookie conf name value =
+  def
+    { setCookieName  = TS.encodeUtf8 name
+    , setCookieValue = TS.encodeUtf8 value
+    , setCookiePath = Just $ TS.encodeUtf8 "/"
+    , setCookieSecure = Conf.https conf
+    }
+
+setCookie :: (Monad m) => SetCookie -> ActionT e m ()
+setCookie name = addHeader "Set-Cookie" (TL.decodeUtf8 . toLazyByteString $ renderSetCookie name)
+
+setSimpleCookie :: (Monad m) => 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 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) => Conf -> TS.Text -> ActionT e m ()
+deleteCookie conf name = setCookie $ (makeSimpleCookie conf name "") { setCookieExpires = Just $ posixSecondsToUTCTime 0 }