ME WANT COOKIES

matebeamter.cabal

@@ -20,8 +20,10 @@ executable matebeamter
   main-is:             Main.hs
   other-modules:       API
                      , Client
+                     , ClientAuth
                      , Util
                      , Hash
+                     , Session
                      , Types
                      , Types.Page
                      , Types.Reader
@@ -48,11 +50,15 @@ executable matebeamter
                      , blaze-markup
                      , text
                      , bytestring
+                     , hashable
                      , warp
                      , wai
                      , wai-logger
+                     , wai-session
                      , http-client
                      , http-api-data
+                     , http-types
+                     , cookie
                      , mtl
                      , i18n
                      , cookie
@@ -60,6 +66,9 @@ executable matebeamter
                      , random-bytestring
                      , base64-bytestring
                      , cryptonite
+                     , stm
+                     , stm-containers
+                     , vault
   hs-source-dirs:      src
   default-language:    Haskell2010
   ghc-options:         -Wall

src/Client.hs

@@ -50,6 +50,7 @@ mateApi = Proxy
   productStockRefill :<|>
   productStockUpdate :<|>
   productList :<|>
+  productShortList :<|>
 
   buy :<|>
 

src/ClientAuth.hs

@@ -0,0 +1,12 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings #-}
+module ClientAuth where
+
+import Servant.API (AuthProtect)
+import Servant.Client.Core
+
+type instance AuthClientData (AuthProtect "header-auth") = String
+
+authenticateReq :: String -> Request -> Request
+authenticateReq s req = addHeader "Authentication" s req

src/Control/User.hs

@@ -4,6 +4,7 @@ module Control.User where
 
 import Servant
 import Servant.Client
+import Servant.Client.Core.Auth
 import Servant.Server
 
 import Data.String (fromString)
@@ -14,6 +15,8 @@ import Control.Monad (void)
 import Control.Monad.Reader (ask)
 import Control.Monad.IO.Class (liftIO)
 
+import Network.HTTP.Types.Status
+
 -- imports from "mateamt"
 
 import qualified "mateamt" API as MA
@@ -23,9 +26,11 @@ import qualified "mateamt" Types as MT
 
 import Types
 import Client
+import ClientAuth
 import View
 import Hash
 import API
+import Util
 
 userSelectControl :: UserHandler UserSelectPage
 userSelectControl = do
@@ -57,12 +62,39 @@ userNewPostControl us@(MT.UserSubmit ident email pass) = do
       { MT.userSubmitPassHash = hashedPass
       })
     backend
-  throwError $ err303
+  redirect303 userSelectLink
-    { errHeaders = [
-      ("Location", "/" <> (fromString $ show $ linkURI $ userSelectLink))
-      ]
-    }
 
 userOverviewControl :: Int -> UserHandler UserOverviewPage
 userOverviewControl uid = do
-  error "Not yet implemented"
+  (ReadState l10n backend _) <- ask
+  let loc = Locale "en"
+  euser <- liftIO $ runClientM
+    (userGet (mkAuthenticatedRequest "secret" authenticateReq) uid)
+    backend
+  eproducts <- liftIO $ runClientM
+    (productShortList Nothing)
+    backend
+  case (euser, eproducts) of
+    (Right ud, Right prods) ->
+      return $ userOverviewPage l10n loc ud prods
+    (Left uerr, Right _) -> case uerr of
+      FailureResponse _ resp ->
+        if statusCode (responseStatusCode resp) == 401
+        then
+          redirect303 authLink
+        else
+          throwError $ err500
+            { errBody = fromString (show uerr)
+            }
+      _ ->
+        throwError $ err500
+          { errBody = fromString (show uerr)
+          }
+    (Right _, Left perr) ->
+      throwError $ err500
+        { errBody = fromString (show perr)
+        }
+    (Left uerr, Left perr) ->
+      throwError $ err500
+        { errBody = (fromString $ show uerr) <> " " <> (fromString $ show perr)
+        }

src/Main.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Main where
 
 import Servant
@@ -6,33 +8,49 @@ import Servant.Client
 
 import Network.Wai.Handler.Warp
 import Network.Wai.Logger
+import Network.Wai.Session
 
 import Network.HTTP.Client hiding (Proxy)
 
+import Web.Cookie (defaultSetCookie)
+
 import Control.Monad.Reader
 
 import Data.Text.I18n
 import Data.Text.I18n.Po
 
+import Data.ByteString (ByteString)
+
+import qualified Data.Vault.Lazy as V
+
 -- internal imports
 
 import API
 import Types
 import View
 import Control
+import Session
 
 main :: IO ()
 main = do
   manager <- newManager defaultManagerSettings
   (l10n, _) <- getL10n "./locales"
   withStdoutLogger $ \ilog -> do
+    sessKey <- V.newKey :: IO (V.Key (Session IO ByteString ByteString))
     let settings = setPort 3000 $ setLogger ilog defaultSettings
+        sessMap = sessionMap
         initState = ReadState
           -- { rsManager = manager
           { rsL10n       = l10n
           , rsBackend    = mkClientEnv manager (BaseUrl Http "localhost" 8000 "")
           , rsHashParams = recommendedHashParams
           }
+        cookieMiddleware = withSession
+          (sessionStore genSessionId sessMap)
+          "mateamt-cookies"
+          defaultSetCookie
+          sessKey
+          
     runSettings settings (userApp initState)
 
 userApp initState = serveWithContext userApi (EmptyContext) $

src/Session.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Session where
+
+import Network.Wai.Session
+
+import Control.Monad (liftM)
+
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TVar
+
+import qualified StmContainers.Map as SMap
+
+import System.IO.Unsafe (unsafePerformIO)
+
+import Data.Maybe (fromJust)
+
+import Data.ByteString (ByteString)
+
+import Data.Hashable
+
+sessionMap = unsafePerformIO SMap.newIO
+
+sessionStore
+  :: IO ByteString
+  -> SMap.Map ByteString (SMap.Map ByteString ByteString)
+  -> SessionStore IO ByteString ByteString
+  -- -> IO ((key2 -> IO (Maybe value)), (key2 -> value -> IO ()))
+sessionStore genKey inmap =
+  mapStore genKey inmap
+  where
+    mapStore
+      :: IO ByteString
+      -> SMap.Map ByteString (SMap.Map ByteString ByteString)
+      -> SessionStore IO ByteString ByteString
+      -- -> IO ((key2 -> IO (Maybe value1)), (key2 -> value1 -> IO ()))
+    mapStore gen map = (\inkey -> 
+      case inkey of
+        Just k -> do
+          mcmap <- atomically $ SMap.lookup k map
+          case mcmap of
+            Just cmap ->
+              return $ (sessionMapFromSTMMap cmap, genKey)
+            Nothing -> (mapStore genKey map) Nothing
+        Nothing -> do
+          nkey <- gen
+          nmap <- atomically $ SMap.new
+          atomically $ SMap.insert nmap nkey map
+          cmap <- fromJust <$> (atomically $ SMap.lookup nkey map)
+          return $ (sessionMapFromSTMMap cmap, gen)
+      )
+
+
+sessionMapFromSTMMap
+  :: SMap.Map ByteString ByteString
+  -> Session IO ByteString ByteString
+sessionMapFromSTMMap inmap =
+  ( \k -> atomically $ SMap.lookup k inmap
+  , \k v -> atomically $ SMap.insert v k inmap
+  )

src/Util.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Util where
 
 import Servant hiding (addHeader)
@@ -18,19 +19,12 @@ import Data.List.Split (chunksOf)
 
 import Data.String (fromString)
 
+import Control.Monad.Error
+
 import Web.Cookie
 
 import Text.Printf (printf)
 
-authenticateReq
-  :: ToHttpApiData a
-  => a
-  -> Servant.Client.Core.Request.Request
-  -> Servant.Client.Core.Request.Request
-authenticateReq s req = addHeader "Authentication" s req
-
-type instance AuthClientData (AuthProtect "header-auth") = String
-
 setCookie
   :: SetCookie
   -> Request
@@ -47,3 +41,14 @@ formatMoney amount = pre <> t <> "," <> c
     c = fromString $ snd sp
     sp = tail <$>
       break (== '.') (printf "%.2f" (abs amount))
+
+redirect303
+  :: MonadError ServerError m
+  => Link
+  -> m a
+redirect303 link =
+  throwError $ err303
+    { errHeaders =
+      [ ("Location", "/" <> (fromString $ show $ linkURI $ link))
+      ]
+    }