git vomit

matebeamter.cabal

@@ -19,21 +19,33 @@ extra-source-files:  CHANGELOG.md
 executable matebeamter
   main-is:             Main.hs
   other-modules:       API
+                     , Client
+                     , AuthUtil
                      , Types
                      , Types.Page
+                     , Types.Reader
+                     , Control
+                     , Control.Auth
+                     , Control.User
                      , View
                      , View.Auth
+                     , View.User
   -- other-extensions:
   build-depends:       base ^>=4.12.0.0
                      , mateamt
                      , servant
                      , servant-server
                      , servant-client
+                     , servant-client-core
                      , servant-blaze
                      , servant-rawm
+                     , aeson
                      , blaze-html
                      , text
                      , warp
+                     , wai
                      , wai-logger
+                     , http-client
+                     , mtl
   hs-source-dirs:      src
   default-language:    Haskell2010

src/API.hs

@@ -21,3 +21,5 @@ import View
 
 type UserAPI =
   "auth" :> Get '[HTML] AuthPage
+
+  :<|> "user" :> Capture "id" Int :> Get '[HTML] UserPage

src/AuthUtil.hs

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

src/Client.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE UndecidableInstances  #-}
+{-# LANGUAGE PackageImports        #-}
+module Client where
+
+import Servant
+import Servant.Client
+
+import Network.HTTP.Client hiding (Proxy)
+
+import Control.Monad.IO.Class (liftIO)
+
+-- imports from mateamt
+
+import qualified "mateamt" API as MT 
+import qualified "mateamt" Types as MT 
+
+-- internal imports
+
+import Types
+
+mateApi :: Proxy MT.MateAPI
+mateApi = Proxy
+
+( authGet :<|>
+  authSend :<|>
+  authLogout :<|>
+
+  userNew :<|>
+  userGet :<|>
+  userUpdate :<|>
+  userList :<|>
+  userRecharge :<|>
+  userTransfer :<|>
+
+  productNew :<|>
+  productOverview :<|>
+  productStockRefill :<|>
+  productStockUpdate :<|>
+  productList :<|>
+
+  buy :<|>
+
+  journalShow :<|>
+
+  avatarGet :<|>
+  avatarInsert :<|>
+  avatarUpdate :<|>
+  avatarList
+  ) = client mateApi
+
+getClients clientEnv = hoistClient
+    mateApi
+    ( fmap (either (error . show) id)
+    . (`runClientM` mkClientEnv clientEnv (BaseUrl Http "localhost" 8000 "/")))
+    (client mateApi)

src/Control.hs

@@ -0,0 +1,6 @@
+module Control
+  ( module C
+  ) where
+
+import Control.Auth as C
+import Control.User as C

src/Control/Auth.hs

@@ -0,0 +1,12 @@
+module Control.Auth where
+
+import Servant.Server (Server)
+
+-- internal imports
+
+import Types
+import View
+
+authControl :: UserHandler AuthPage
+authControl = do
+  error "Not yet implemented properly"

src/Control/User.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+module Control.User where
+
+import Servant.Server (Server)
+import Servant.Client
+import Servant.Client.Core.Auth
+
+import Data.Aeson (decode)
+
+import Control.Monad.Reader (ask)
+import Control.Monad.IO.Class (liftIO)
+
+import Network.HTTP.Client
+
+-- imports from mateamt
+
+import qualified "mateamt" Types as MT
+
+-- internal imports
+
+import Types
+import Client
+import View
+import AuthUtil
+import API
+
+userListControl :: Int -> UserHandler UserPage
+userListControl uid = do
+  manager <- liftIO $ newManager defaultManagerSettings
+  muser <- liftIO $ runClientM
+        (userList (Just MT.All))
+        (mkClientEnv manager (BaseUrl Http "localhost" 8000 ""))
+  error (show muser)

src/Main.hs

@@ -6,23 +6,35 @@ import Servant.Server
 import Network.Wai.Handler.Warp
 import Network.Wai.Logger
 
+import Network.HTTP.Client hiding (Proxy)
+
+import Control.Monad.Reader
+
 -- internal imports
 
 import API
 import Types
 import View
+import Control
 
 main :: IO ()
 main = do
+  manager <- newManager defaultManagerSettings
   withStdoutLogger $ \ilog -> do
     let settings = setPort 3000 $ setLogger ilog defaultSettings
-    runSettings settings app
+        initState = ReadState
+          { rsManager = manager
+          }
+    runSettings settings (userApp initState)
 
-app :: Application
-app = serve userApi userServer
+userApp initState = serveWithContext userApi (EmptyContext) $
+  hoistServerWithContext
+    userApi
+    Proxy
+    (`runReaderT` initState)
+    ( authControl
+    :<|> userListControl
+    )
 
 userApi :: Proxy UserAPI
 userApi = Proxy
-
-userServer :: Server UserAPI
-userServer = return authPage

src/Model.hs

@@ -0,0 +1,5 @@
+module Model
+  ( module M
+  ) where
+
+import Model.Auth as M

src/Model/Auth.hs

@@ -0,0 +1,3 @@
+module Model.Auth where
+
+

src/Model/User.hs

@@ -0,0 +1,7 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+module Model.User where
+
+import qualified "mateamt" Types as MT
+
+

src/Types.hs

@@ -3,3 +3,4 @@ module Types
   ) where
 
 import Types.Page as T
+import Types.Reader as T

src/Types/Reader.hs

@@ -0,0 +1,13 @@
+module Types.Reader where
+
+import Network.HTTP.Client (Manager)
+
+import Servant (Handler)
+
+import Control.Monad.Reader (ReaderT)
+
+data ReadState = ReadState
+  { rsManager :: Manager
+  }
+
+type UserHandler = ReaderT ReadState Handler

src/View.hs

@@ -3,3 +3,4 @@ module View
   ) where
 
 import View.Auth as V
+import View.User as V

src/View/User.hs

@@ -0,0 +1,12 @@
+{-# LANGUAGE OverloadedStrings #-}
+module View.User where
+
+import qualified Text.Blaze.Html5 as H
+
+import Types
+
+type UserPage = H.Html
+
+userPage :: UserPage
+userPage = template initPage $ do
+  H.p $ "Test"