4f0da78 · denis · git.iko.soy

git.iko.soy/denis

Slightly refactored code

commit4f0da78e0b9e48d9df40858e34caffa2e97f31b7 authoriko <ilyakooo0@gmail.com> dateWed 27 Feb 2019, 02:12 (8 years ago) parentfcef7e8

15 files changed+81−130

compare with master

unifiedsplit

denis/docs/Docs.hs−26 denis/src/Data/Connection.hs+2−5 denis/src/Data/Post.hs+10−13 denis/src/Data/PostElement.hs+10−1 denis/src/Data/Query.hs+3−9 denis/src/Data/RowConvertable.hs−28 denis/src/Data/Schema.hs−4 denis/src/Data/User.hs+8 denis/src/Server/API.hs+17−13 denis/src/Server/API/Draft.hs+8−1 denis/src/Server/API/Posts.hs+8−3 denis/src/Server/App.hs+1−1 denis/src/Server/Auth.hs+12−11 denis/src/Server/Logger.hs−7 denis/src/Server/Server.hs+2−8

denis/docs/Docs.hs−26

@@ -12,7 +12,6 @@ import qualified Data.Text as T

1212import Servant.Server

1313import Servant

1414import Server.Auth

15−import Control.Lens

1615import Data.Aeson

1716import Data.PostElement

1817import Data.Proxy

@@ -25,39 +24,14 @@ import Server.Logger

2524

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

2726

28−instance ToSample AuthenticationCredits where

29− toSamples _ = samples $ map AuthenticationCredits [56, 103, 8]

30−

3127instance ToSample Char where

3228 toSamples _ = singleSample $ 'c'

33−

34−instance HasDocs api => HasDocs ((AuthProtect "basicAuth") :> api) where

35− docsFor Proxy (endpoint, action) =

36− docsFor (Proxy :: Proxy api) (endpoint, action & notes <>~ [DocNote "Authentication" ["This method requires cookies set in the `POST /authenticate` method.\n\nReturns error `401 Unauthorized` if the cookies are invalid or don't premit access to the requested data."]])

3729

38−instance ToSample (PostData a) where

39− toSamples _ = samples $ [PostData 8 17] <*> (map snd $ toSamples Proxy)

40−

41−instance ToSample (PostElement p) where

42− toSamples _ = samples [

43− Markdown "# This is a markdown title\nThis is body.",

44− Markdown "## This is a subtitle\n_hello._"

45− ]

46−

4730instance ToSample Int64 where

4831 toSamples _ = samples [1, 7, 2, 19]

4932

5033instance ToSample Word64 where

5134 toSamples _ = samples [1, 7, 2, 19]

5235

53−instance ToSample User where

54− toSamples _ = samples [User 8 "Vasya" "Pupkin", User 69 "Seva" "Leonidov"]

55−

56−instance ToSample UserPostsRequest where

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

58−

59−instance ToSample DraftUpdate where

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

61−

6236instance ToSample Log where

6337 toSamples _ = samples ["Log"]

denis/src/Data/Connection.hs+2−5

@@ -15,15 +15,11 @@ module Data.Connection (

1515) where

1616

1717import Squeal.PostgreSQL

18−import Squeal.PostgreSQL.PQ

1918import Squeal.PostgreSQL.Pool

20−import qualified Generics.SOP as SOP

2119import Data.Schema

2220import Server.App

23−import Control.Monad.Base

2421import Control.Monad.Reader

25−import Servant.Server

26−import Control.Monad.Error

22+import Control.Monad.Except

2723import Servant.Server

2824

2925type StaticPQ = PoolPQ Schema Handler

@@ -35,4 +31,5 @@ runQ err req = handleSqueal (const $ throwError err) $ asks getPool >>= lift . r

3531runQ' :: DBConnection -> ServantErr -> StaticPQ a -> Handler a

3632runQ' conn err req = handleSqueal (const $ throwError err) $ runPoolPQ req conn

3733

34+runQnotFound :: StaticPQ a -> App a

3835runQnotFound = runQ err404

denis/src/Data/Post.hs+10−13

@@ -10,10 +10,7 @@

1010

1111module Data.Post (

1212 Post,

13− postId,

14− postAuthorId,

15− postBody,

16− PostElement(..),

13+ PostElement,

1714 PostQuote(..),

1815 PostRow,

1916 PostQuoteRow,

@@ -27,24 +24,24 @@ module Data.Post (

2724 DraftId,

2825 mkDraft,

2926 fromDraft,

30−

31− -- for docs only

32− PostData(..),

33− PostType(..)

27+ PostData(..)

3428) where

3529

3630import Data.Int (Int64)

37−-- import Squeal.PostgreSQL

38−-- import Squeal.PostgreSQL.Render

39−-- import qualified Squeal.PostgreSQL.PQ as P

4031import qualified Generics.SOP as SOP

4132import qualified GHC.Generics as GHC

42−-- import Squeal.PostgreSQL.Schema

4333import Data.Aeson

4434import qualified Data.Map.Lazy as M

35+import Servant.Docs (ToSample, toSamples, samples)

36+import Data.Proxy

4537

4638import Data.PostElement

47−-- import Data.RowConvertable

39+

40+-- MARK: Documentation

41+

42+instance ToSample (PostData a) where

43+ toSamples _ = samples $ [PostData 8 17] <*> (map snd $ toSamples Proxy)

44+

4845

4946-- MARK: Actual type

5047

denis/src/Data/PostElement.hs+10−1

@@ -9,7 +9,7 @@

1010

1111module Data.PostElement (

12− PostElement(..),

12+ PostElement,

1313 ElementRow(..),

1414 elementsToRows,

1515 PostQuoteRow(..),

@@ -26,6 +26,15 @@ import qualified Data.Map.Lazy as M

2626import Data.List (sortBy)

2727import Data.Function (on)

2828import Control.Applicative ((<|>))

29+import Servant.Docs (ToSample, toSamples, samples)

30+

31+-- MARK: Documentation

32+

33+instance ToSample (PostElement p) where

34+ toSamples _ = samples [

35+ Markdown "# This is a markdown title\nThis is body.",

36+ Markdown "## This is a subtitle\n_hello._"

37+ ]

2938

3039

3140-- MARK: PostElement

denis/src/Data/Query.hs+3−9

@@ -20,19 +20,13 @@ module Data.Query (

2020) where

2121

2222import Squeal.PostgreSQL

23−import Squeal.PostgreSQL.Expression

24−import Squeal.PostgreSQL.Schema

2523import Data.User

2624import Data.Post

2725import Data.Schema

28−import Data.List

29−import Data.Function (on)

26+-- import Data.Function (on)

3027import qualified Data.Map.Lazy as M

31−import Server.App

3228import Data.Connection

3329import Data.PostElement

34−import Control.Monad.Base

35−import Control.Monad ((<$!>))

3630import qualified Servant as S

3731import Control.Monad.Morph

3832import Data.Maybe

@@ -180,7 +174,7 @@ updateDraft uId dId els = transactionally_ $ do

180174 if c /= 1 then

181175 lift $ S.throwError S.err404

182176 else do

183− manipulateParams deleteElementsForIdQ (Only dId)

177+ _ <- manipulateParams deleteElementsForIdQ (Only dId)

184178 traversePrepared_ createDraftElementRowsQ $ elementsToRows dId els

185179

186180getDraftElementRowsQ :: Query Schema (TuplePG (Only DraftId)) (RowPG (ElementRow Draft))

@@ -200,7 +194,7 @@ publishDraft uId dId = transactionally_ $ do

200194 pId' <- manipulateParams createPostRowQ (Only uId)

201195 pId <- lift $ fromOnly <$> getRow 0 pId'

202196 traversePrepared_ createPostElementRowsQ $ map (fromDraft pId) els

203− manipulateParams deleteDraftQ (Only dId)

197+ _ <- manipulateParams deleteDraftQ (Only dId)

204198 return ()

205199

206200

denis/src/Data/RowConvertable.hsdeleted−28

@@ -1,28 +0,0 @@

1−{-# LANGUAGE

2− DataKinds ,

3− DeriveGeneric ,

4− OverloadedLabels,

5− OverloadedStrings ,

6− TypeApplications ,

7− TypeOperators #-}

8−

9−

10−module Data.RowConvertable (

11− -- RowConvertable(..)

12− ) where

13−

14−import Data.Int (Int64)

15−import Squeal.PostgreSQL

16−import Squeal.PostgreSQL.Schema

17−import GHC.TypeLits (Symbol)

18−import Squeal.PostgreSQL.Render

19−import qualified Squeal.PostgreSQL.PQ as P

20−import qualified Generics.SOP as SOP

21−import qualified GHC.Generics as GHC

22−import Data.Text (Text)

23−

24−

25−-- class RowConvertable t r where

26−-- convertToRow :: a -> RowPG r

27−-- fromRow :: TuplePG r -> a

28−

denis/src/Data/Schema.hs−4

@@ -12,10 +12,6 @@ module Data.Schema (

1212) where

1313

1414import Squeal.PostgreSQL

15−import Squeal.PostgreSQL.Expression

16−import Squeal.PostgreSQL.Schema

17−import Data.User

18−import Data.Post

1915

2016type Schema =

2117 '[

denis/src/Data/User.hs+8

@@ -17,6 +17,14 @@ import qualified Generics.SOP as SOP

1717import qualified GHC.Generics as GHC

1818import Data.Text (Text)

1919import Data.Aeson

20+import Servant.Docs (ToSample, toSamples, samples)

21+

22+-- MARK: Documentation

23+

24+instance ToSample User where

25+ toSamples _ = samples [User 8 "Vasya" "Pupkin", User 69 "Seva" "Leonidov"]

26+

27+-- MARK: Implementation

2028

2129type UserId = Int64

2230

denis/src/Server/API.hs+17−13

@@ -1,7 +1,10 @@

1−{-# LANGUAGE DataKinds,

1+{-# LANGUAGE

2+ FlexibleInstances,

3+ DataKinds,

24 TypeOperators,

35 OverloadedStrings,

46 ScopedTypeVariables #-}

7+{-# OPTIONS_GHC -Wno-orphans #-}

69module Server.API (

710 API,

@@ -11,32 +14,33 @@ module Server.API (

1114

1215import Data.Proxy

1316import Servant.API

14−-- import Servant

15−import Servant.Server.Experimental.Auth

1617import Data.User

17−import qualified Data.Post as P

1818import Server.Auth

19−import Data.ByteString

20−import Data.Int (Int64)

19+import Data.Int ()

2120import Servant.Server

2221import Data.Connection

2322import Data.Query

24−import Server.Auth

2523import Server.App

26−import Control.Monad.Error

2724import Server.API.Draft

2825import Server.API.Posts

2926import Server.Logger

27+import Servant.Docs (HasDocs, docsFor, notes, DocNote(DocNote))

28+import Control.Lens

29+

30+-- MARK: Documentation

31+

32+instance HasDocs api => HasDocs (Authentication :> api) where

33+ docsFor Proxy (endpoint, action) =

34+ docsFor (Proxy :: Proxy api) (endpoint, action & notes <>~ [DocNote "Authentication" ["This method requires cookies set in the `POST /authenticate` method.\n\nReturns error `401 Unauthorized` if the cookies are invalid or don't premit access to the requested data."]])

35+

36+-- MARK: Implementation

3037

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

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

33− Just y -> return y

34− Nothing -> throwError err404))

38+type Authentication = AuthProtect "basicAuth"

3539

3640type API =

3741 LoggerAPI :<|>

3842 "authenticate" :> AuthenticationHandler :<|>

39− AuthProtect "basicAuth" :> (

43+ Authentication :> (

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

4145 "posts" :> PostApi :<|>

4246 "drafts" :> DraftApi

denis/src/Server/API/Draft.hs+8−1

@@ -17,12 +17,19 @@ import Servant.API

1717import qualified Data.Post as P

1818import Data.Aeson

1919import GHC.Generics

20−import Data.Int (Int64)

2120import Server.App

2221import Servant.Server

2322import Data.Query

2423import Data.User

2524import Data.Connection

25+import Servant.Docs (ToSample, toSamples, samples)

26+

27+-- MARK: Documentation

28+

29+instance ToSample DraftUpdate where

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

31+

32+-- MARK: Implementation

2633

2734data DraftUpdate = DraftUpdate {

2835 draftId :: P.DraftId,

denis/src/Server/API/Posts.hs+8−3

@@ -12,12 +12,9 @@ module Server.API.Posts (

1212 UserPostsRequest(..)

1313) where

1414

15−import Data.Proxy

1615import Servant.API

1716import qualified Data.Post as P

1817import Data.Aeson

19−import GHC.Generics

20−import Data.Int (Int64)

2118import Server.App

2219import Servant.Server

2320import Data.Query

@@ -25,7 +22,15 @@ import Data.User

2522import Data.Connection

2623import Servant

2724import Data.Word (Word64)

25+import Servant.Docs (ToSample, toSamples, samples)

2826

27+-- MARK: Documentation

28+

29+instance ToSample UserPostsRequest where

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

31+

32+-- MARK: Implementation

33+

2934data UserPostsRequest = UserPostsRequest {

3035 userPostRequestId :: UserId,

3136 userPostRequestLimit :: Word64

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

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

2121import Data.Schema

2222import Generics.SOP (K)

2323import Squeal.PostgreSQL.PQ (Connection)

24−import Control.Monad.IO.Class

24+import Control.Monad.IO.Class ()

2525

2626type App = ReaderT Config Handler

2727

denis/src/Server/Auth.hs+12−11

@@ -21,15 +21,13 @@ module Server.Auth (

2121

2222import Server.App

2323import Data.User

24−import Data.ByteString

24+import qualified Data.ByteString as BS

2525import qualified Data.ByteString.Char8 as C

2626import qualified Data.ByteString.Lazy.Char8 as L

2727import Data.Query

28−import Data.Binary (decode)

2928import Server.Error

30−import Control.Monad.Error

29+import Control.Monad.Except

3130import Text.Read (readMaybe)

32−import Squeal.PostgreSQL.PQ

3331import Data.Connection

3432import Servant.Server.Experimental.Auth

3533import Servant.API

@@ -37,12 +35,18 @@ import Network.Wai (Request, requestHeaders)

3735import Servant.Server

3836import Web.Cookie

3937import Data.Time.Clock

40−import Data.Monoid ((<>))

41−import Data.Text

4238import Data.Proxy

4339import qualified GHC.Generics as GHC

4440import Data.Aeson

4541import Data.Binary.Builder (toLazyByteString)

42+import Servant.Docs (ToSample, samples, toSamples)

43+

44+-- MARK: Documentation

45+

46+instance ToSample AuthenticationCredits where

47+ toSamples _ = samples $ map AuthenticationCredits [56, 103, 8]

48+

49+-- MARK: Implementation

4650

4751type AuthenticationHandler = ReqBody '[JSON] AuthenticationCredits :> PostNoContent '[JSON, PlainText, FormUrlEncoded] (Headers '[Header "Set-Cookie" String] NoContent)

4852

@@ -54,7 +58,6 @@ instance FromJSON AuthenticationCredits

5458

5559authenticate :: ServerT AuthenticationHandler App

5660authenticate (AuthenticationCredits uId) = do

57− conn <- ask

5861 expire <- liftIO $ fmap (addUTCTime (1 * 24 * 60 * 60)) getCurrentTime -- one days

5962 tId <- fmap userId . runQ invalidToken . getUser $ uId

6063 let cookie = defaultSetCookie {

@@ -67,7 +70,7 @@ authenticate (AuthenticationCredits uId) = do

6770 return $ addHeader (L.unpack . toLazyByteString . renderSetCookie $ cookie) NoContent

6871

6972

70−checkToken :: DBConnection -> ByteString -> Handler UserId

73+checkToken :: DBConnection -> BS.ByteString -> Handler UserId

7174checkToken conn token = do

7275 uId <- case ((readMaybe . C.unpack) token :: Maybe UserId) of

7376 Just uId -> return uId

@@ -83,11 +86,9 @@ authHandler conn = mkAuthHandler handler

8386 cookie <- maybeToEither "Missing cookie header" $ lookup "cookie" $ requestHeaders req

8487 maybeToEither "Missing token in cookie" $ lookup cookieTokenKey $ parseCookies cookie

8588

86−cookieTokenKey :: ByteString

89+cookieTokenKey :: BS.ByteString

8790cookieTokenKey = "servant-auth-cookie"

8891

89−cookieTokenKeyString = C.unpack cookieTokenKey

90−

9192type instance AuthServerData (AuthProtect "basicAuth") = UserId

9293

9394genAuthServerContext :: DBConnection -> Context (AuthHandler Request UserId ': '[])

denis/src/Server/Logger.hs−7

@@ -14,21 +14,14 @@ import Network.Wai

1414import Control.Concurrent.STM

1515import Data.CyclicBuffer

1616import Servant

17−import Servant.API

18−import Servant.Server

1917import Data.Text.Encoding

2018import qualified Data.Text as T

21−import Data.Foldable

2219import qualified Data.ByteString as BL

2320import Data.List

2421import Server.App

25−import Data.CaseInsensitive (original)

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

27−import Network.HTTP.Types.Header

2822import Network.Wai.Middleware.RequestLogger

2923import Data.Default.Class

3024import qualified System.Log.FastLogger as FL

31−import Data.ByteString.Char8 (unpack)

3225

3326type Log = T.Text

3427

denis/src/Server/Server.hs+2−8

@@ -9,7 +9,6 @@ import Server.Auth

99import Server.App

1010

1111import Servant.Server

12−import Servant.API

1312import System.Environment

1413import qualified Data.ByteString.Char8 as B

1514import Squeal.PostgreSQL.Pool

@@ -33,7 +32,7 @@ getServerPort = maybe 2000 read <$> lookupEnv "PORT"

3332getConfig :: IO Config

3433getConfig = do

3534 databaseURL <- getDBString

36− conn <- createConnectionPool databaseURL 1 0.5 10

35+ conn <- createConnectionPool databaseURL 3 0.5 10

3736 return $ Config conn

3837

3938runServer :: IO ()

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

4140 port <- getServerPort

4241 cfg <- getConfig

4342 let ctx = genAuthServerContext $ getPool cfg

44− (middleLogger, logger) <- mkLogger 50

43+ (middleLogger, logger) <- mkLogger 100

4544 let serverAPI = mkServerAPI logger

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

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

48− -- TODO: remove simpleCors

49−

50−-- runServer :: IO ()

51−-- runServer = do

52−-- s <- getServer

5347

5448policy :: CorsResourcePolicy

5549policy = CorsResourcePolicy {