diff --git a/matebeamter.cabal b/matebeamter.cabal index b6dc189..f83f422 100644 --- a/matebeamter.cabal +++ b/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 diff --git a/src/Client.hs b/src/Client.hs index fa47a8d..b6bec4b 100644 --- a/src/Client.hs +++ b/src/Client.hs @@ -50,6 +50,7 @@ mateApi = Proxy productStockRefill :<|> productStockUpdate :<|> productList :<|> + productShortList :<|> buy :<|> diff --git a/src/ClientAuth.hs b/src/ClientAuth.hs new file mode 100644 index 0000000..9420297 --- /dev/null +++ b/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 diff --git a/src/Control/User.hs b/src/Control/User.hs index 7623b4d..83769a0 100644 --- a/src/Control/User.hs +++ b/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 - { errHeaders = [ - ("Location", "/" <> (fromString $ show $ linkURI $ userSelectLink)) - ] - } + redirect303 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) + } diff --git a/src/Main.hs b/src/Main.hs index 630879c..b91f528 100644 --- a/src/Main.hs +++ b/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) $ diff --git a/src/Session.hs b/src/Session.hs new file mode 100644 index 0000000..76db46d --- /dev/null +++ b/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 + ) diff --git a/src/Util.hs b/src/Util.hs index 9f9fead..b59242e 100644 --- a/src/Util.hs +++ b/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)) + ] + }