Merge branch 'with-ghcjs' into 'master'

Use Haskell on the frontend

See merge request guyonvarch/shared-cost!2

1 files changed, 54 insertions, 0 deletions

diff --git a/server/src/Cookie.hs b/server/src/Cookie.hs
new file mode 100644
index 0000000..f79a1fa
--- /dev/null
+++ b/server/src/Cookie.hs
@@ -0,0 +1,54 @@
+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.Cookie
+import           Web.Scotty.Trans
+
+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 }