a403d84 · denis · git.iko.soy

denis/docs/Docs.hs+5−1

compare with master

unifiedsplit

@@ -21,6 +21,7 @@ import Data.Int (Int64)

21import Data.Word (Word64)

22import Server.API.Posts

23import Server.API.Draft

24+import Server.Logger

24

25

25main = writeFile "docs.md" . markdown . docs . pretty $ serverProxy

26main = writeFile "docs.md" . markdown . docs . pretty $ serverProxy

26

27

@@ -56,4 +57,7 @@ instance ToSample UserPostsRequest where

56 toSamples _ = samples [UserPostsRequest 8 10, UserPostsRequest 42 20]

57 toSamples _ = samples [UserPostsRequest 8 10, UserPostsRequest 42 20]

57

58

58instance ToSample DraftUpdate where

59instance ToSample DraftUpdate where

59− toSamples _ = samples $ [DraftUpdate 8] <*> (map snd $ toSamples Proxy)

60+ toSamples _ = samples $ [DraftUpdate 8] <*> (map snd $ toSamples Proxy)

61+

62+instance ToSample Log where

63+ toSamples _ = samples ["Log"]

denis/package.yaml+5

@@ -43,6 +43,11 @@ dependencies:

43- http-types

44- mmorph

45- servant-docs

46+- stm

47+- case-insensitive

48+- wai-extra

49+- data-default-class

50+- fast-logger

46

51

47- lens

52- lens

48

53

denis/src/Data/CyclicBuffer.hsnew file+16

@@ -0,0 +1,16 @@

1+module Data.CyclicBuffer (

2+ CyclicBuffer(elems),

3+ mkCyclicBuffer,

4+ insertIntoCyclicBuffer

5+) where

6+

7+data CyclicBuffer a = CyclicBuffer {

8+ elems :: [a],

9+ limit :: Int

10+}

11+

12+mkCyclicBuffer :: Int -> CyclicBuffer a

13+mkCyclicBuffer lim = CyclicBuffer [] lim

14+

15+insertIntoCyclicBuffer :: CyclicBuffer a -> a -> CyclicBuffer a

16+insertIntoCyclicBuffer (CyclicBuffer els lim) el = CyclicBuffer (take lim $ el:els) lim

denis/src/Server/API.hs+9−5

@@ -6,7 +6,7 @@

6module Server.API (

7 API,

8 serverProxy,

9− serverAPI

9+ mkServerAPI

10) where

11

12import Data.Proxy

@@ -26,14 +26,16 @@ import Server.App

26import Control.Monad.Error

27import Server.API.Draft

28import Server.API.Posts

29+import Server.Logger

29

30

30maybeNotFound :: App (Maybe a) -> App a

31maybeNotFound :: App (Maybe a) -> App a

31maybeNotFound = (>>= (\t -> case t of

32maybeNotFound = (>>= (\t -> case t of

32 Just y -> return y

33 Just y -> return y

33 Nothing -> throwError err404))

34 Nothing -> throwError err404))

34

35

36+type API =

37+ LoggerAPI :<|>

35−type API = "authenticate" :> AuthenticationHandler

38+ "authenticate" :> AuthenticationHandler :<|>

36− :<|>

37 AuthProtect "basicAuth" :> (

39 AuthProtect "basicAuth" :> (

38 "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User] :<|>

40 "users" :> ReqBody '[JSON] [UserId] :> Post '[JSON] [User] :<|>

39 "posts" :> PostApi :<|>

41 "posts" :> PostApi :<|>

@@ -43,8 +45,10 @@ type API = "authenticate" :> AuthenticationHandler

43serverProxy :: Proxy API

45serverProxy :: Proxy API

44serverProxy = Proxy

46serverProxy = Proxy

45

47

46−serverAPI :: ServerT API App

48+mkServerAPI :: Logger -> ServerT API App

49+mkServerAPI l =

50+ l :<|>

47−serverAPI = authenticate :<|> (\uId ->

51+ authenticate :<|> (\uId ->

48 mapM (runQnotFound . getUser) :<|>

52 mapM (runQnotFound . getUser) :<|>

49 postApi uId :<|>

53 postApi uId :<|>

50 draftApi uId

54 draftApi uId

denis/src/Server/App.hs+3−1

@@ -11,7 +11,8 @@ module Server.App (

11 DBConnection,

12 Config(..),

13 ask,

14− asks

14+ asks,

15+ liftIO

15) where

16) where

16

17

17import Servant.Server

18import Servant.Server

@@ -20,6 +21,7 @@ import Squeal.PostgreSQL.Pool

20import Data.Schema

21import Data.Schema

21import Generics.SOP (K)

22import Generics.SOP (K)

22import Squeal.PostgreSQL.PQ (Connection)

23import Squeal.PostgreSQL.PQ (Connection)

24+import Control.Monad.IO.Class

23

25

24type App = ReaderT Config Handler

26type App = ReaderT Config Handler

25

27

denis/src/Server/Logger.hsnew file+55

@@ -0,0 +1,55 @@

1+{-# LANGUAGE DataKinds,

2+ TypeOperators,

3+ OverloadedStrings,

4+ ScopedTypeVariables #-}

5+

6+module Server.Logger (

7+ Logger,

8+ LoggerAPI,

9+ mkLogger,

10+ Log

11+) where

12+

13+import Network.Wai

14+import Control.Concurrent.STM

15+import Data.CyclicBuffer

16+import Servant

17+import Servant.API

18+import Servant.Server

19+import Data.Text.Encoding

20+import qualified Data.Text as T

21+import Data.Foldable

22+import qualified Data.ByteString as BL

23+import Data.List

24+import Server.App

25+import Data.CaseInsensitive (original)

26+import Data.Monoid ((<>), mempty, mappend)

27+import Network.HTTP.Types.Header

28+import Network.Wai.Middleware.RequestLogger

29+import Data.Default.Class

30+import qualified System.Log.FastLogger as FL

31+import Data.ByteString.Char8 (unpack)

32+

33+type Log = T.Text

34+

35+type LoggerAPI = "log" :> Get '[PlainText] Log

36+type Logger = App Log

37+

38+mkLogger :: Int -> IO (Middleware, Logger)

39+mkLogger lim = do

40+ buff <- newTVarIO $ mkCyclicBuffer lim

41+ logger <- mkWaiLogger buff

42+ return (logger, getLog buff)

43+

44+getLog :: TVar (CyclicBuffer BL.ByteString) -> Logger

45+getLog buff = decodeUtf8 . BL.concat . intersperse "\n" . elems <$> liftIO (readTVarIO buff)

46+

47+mkWaiLogger :: TVar (CyclicBuffer BL.ByteString) -> IO Middleware

48+mkWaiLogger buff = let

49+ settings = def {

50+ -- outputFormat = CustomOutputFormatWithDetails (\ date req _ _ tDiff bss bldr ->

51+ -- FL.toLogStr (show date) <> (FL.toLogStr . unpack $ fold bss))

52+ outputFormat = Detailed False,

53+ destination = Callback (atomically . modifyTVar buff . flip insertIntoCyclicBuffer . FL.fromLogStr)

54+ }

55+ in mkRequestLogger settings

denis/src/Server/Server.hs+4−1

@@ -17,6 +17,7 @@ import Data.Maybe

17import Control.Monad.Reader

18import Network.Wai.Handler.Warp

19import Network.HTTP.Types.Method

20+import Server.Logger

20

21

21import Network.Wai.Middleware.Cors

22import Network.Wai.Middleware.Cors

22

23

@@ -40,8 +41,10 @@ runServer = do

40 port <- getServerPort

41 port <- getServerPort

41 cfg <- getConfig

42 cfg <- getConfig

42 let ctx = genAuthServerContext $ getPool cfg

43 let ctx = genAuthServerContext $ getPool cfg

44+ (middleLogger, logger) <- mkLogger 50

45+ let serverAPI = mkServerAPI logger

43 let s = hoistServerWithContext serverProxy contextProxy (flip runReaderT cfg) serverAPI

46 let s = hoistServerWithContext serverProxy contextProxy (flip runReaderT cfg) serverAPI

44− runSettings (settings port) $ cors (const $ Just policy) $ serveWithContext serverProxy ctx s

47+ runSettings (settings port) $ cors (const $ Just policy) . middleLogger $ serveWithContext serverProxy ctx s

45 -- TODO: remove simpleCors

48 -- TODO: remove simpleCors

46

49

47-- runServer :: IO ()

50-- runServer :: IO ()