MasseR/ebook-manager
1
0
Fork 0
Code Issues 9 Pull Requests Releases Wiki Activity

Docs support

Browse Source
This commit is contained in:
Mats Rauhala 2018-11-12 21:32:42 +02:00
parent 7928aa1cb6
commit 5727ea5574
10 changed files with 235 additions and 168 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
backend/backend.cabal
View File

@ -68,6 +68,7 @@ executable backend
, servant
, servant-auth
, servant-auth-server
, servant-auth-docs
, servant-docs
, servant-lucid
, servant-multipart
@ -124,6 +125,7 @@ test-suite spec
, servant-auth
, servant-auth-server
, servant-docs
, servant-auth-docs
, servant-lucid
, servant-multipart
, servant-server

6
backend/src/API.hs
View File

@ -25,16 +25,14 @@ import qualified API.Catalogue as Catalogue
data Index = Index
type API = Get '[HTML] (AppView Index)
:<|> Users.API
type API = Users.API
:<|> "api" :> "current" :> Channels.API
:<|> "api" :> "current" :> Books.API
:<|> "api" :> "1" :> Catalogue.VersionedAPI 1
:<|> "api" :> "current" :> Catalogue.VersionedAPI 1
handler :: ServerT API AppM
handler = indexHandler
:<|> Users.handler
handler = Users.handler
:<|> Channels.handler
:<|> Books.handler
:<|> Catalogue.handler

70
backend/src/API/Books.hs
View File

@ -1,40 +1,39 @@
{-# Language DuplicateRecordFields #-}
{-# Language DataKinds #-}
{-# Language TypeFamilies #-}
{-# Language TypeOperators #-}
{-# Language NoImplicitPrelude #-}
{-# Language MultiParamTypeClasses #-}
{-# Language OverloadedStrings #-}
{-# Language TemplateHaskell #-}
{-# Language QuasiQuotes #-}
{-# Language RecordWildCards #-}
{-# Language DeriveGeneric #-}
{-# Language FlexibleInstances #-}
{-# Language TypeApplications #-}
{-# Language DataKinds #-}
{-# Language NamedFieldPuns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module API.Books where
import ClassyPrelude
import Control.Lens
import Control.Monad.Catch (throwM, MonadThrow)
import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.Trans.Maybe
import Crypto.Hash (digestFromByteString)
import Data.Aeson
import Data.ByteArray (convert)
import Data.Generics.Product
import Database
import Database.Book
import Database.Channel
import Database.Tag
import qualified Datastore as DS
import Servant hiding (contentType)
import Servant.Auth as SA
import qualified Servant.Docs as Docs
import Server.Auth
import Types
import Control.Monad.Trans.Maybe
import qualified Datastore as DS
import Data.ByteArray (convert)
import Crypto.Hash (digestFromByteString)
data JsonBook = JsonBook { identifier :: BookID
, contentType :: Text
, title :: Text
@ -43,6 +42,12 @@ data JsonBook = JsonBook { identifier :: BookID
, tags :: [Text] }
deriving (Generic, Show, Eq)
instance Docs.ToSample JsonBook where
toSamples _ = [("Book", JsonBook 13 "epub" "title" (Just "Description") [] [])]
instance Docs.ToSample PostBook where
toSamples _ = [("Book", PostBook "epub" "title" (Just "Description") [] [])]
data PostBook = PostBook { contentType :: Text
, title :: Text
, description :: Maybe Text
@ -58,13 +63,21 @@ instance FromJSON PostBook
type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI
instance Docs.ToCapture (Capture "book_id" BookID) where
toCapture _ = Docs.DocCapture "book_id" "The book id"
type BaseAPI = "books" :> Get '[JSON] [JsonBook]
:<|> "books" :> ReqBody '[JSON] PostBook :> Post '[JSON] JsonBook
:<|> "books" :> Capture "book_id" BookID :> "meta" :> ReqBody '[JSON] JsonBook :> Put '[JSON] JsonBook
:<|> "books" :> Capture "book_id" BookID :> ReqBody '[OctetStream] ByteString :> Put '[JSON] NoContent
:<|> "books" :> Capture "book_id" BookID :> ReqBody '[OctetStream] FileContent :> Put '[JSON] NoContent
:<|> GetBook
type GetBook = "books" :> Capture "book_id" BookID :> Get '[OctetStream] ByteString
newtype FileContent = FileContent { getFileContent :: ByteString } deriving (MimeUnrender OctetStream, MimeRender OctetStream )
instance Docs.ToSample FileContent where
toSamples _ = [("File contents", FileContent "bytes here and there")]
type GetBook = "books" :> Capture "book_id" BookID :> Get '[OctetStream] FileContent
handler :: ServerT API AppM
handler user = listBooksHandler user
@ -73,12 +86,12 @@ handler user = listBooksHandler user
:<|> putBookContentHandler user
:<|> getBookContentHandler user
getBookContentHandler :: AuthResult SafeUser -> BookID -> AppM ByteString
getBookContentHandler :: AuthResult SafeUser -> BookID -> AppM FileContent
getBookContentHandler auth bookId = requireBookOwner auth bookId $ \SafeUser{username} -> do
content <- runMaybeT $ do
Book{contentHash=mHash} <- MaybeT $ runDB (getBook bookId username)
contentHash <- MaybeT $ return (mHash >>= digestFromByteString . unHex)
MaybeT $ DS.get contentHash
FileContent <$> MaybeT (DS.get contentHash)
maybe (throwM err404) return content
requireBookOwner :: AuthResult SafeUser -> BookID -> (SafeUser -> AppM a) -> AppM a
@ -87,8 +100,9 @@ requireBookOwner auth bookId f = flip requireLoggedIn auth $ \u@SafeUser{usernam
unless exists $ throwM err404
runDB (isBookOwner bookId username) >>= \o -> if o then f u else throwM err403
putBookContentHandler :: AuthResult SafeUser -> BookID -> ByteString -> AppM NoContent
putBookContentHandler auth bookId content = requireBookOwner auth bookId $ \SafeUser{username} -> do
putBookContentHandler :: AuthResult SafeUser -> BookID -> FileContent -> AppM NoContent
putBookContentHandler auth bookId fc = requireBookOwner auth bookId $ \SafeUser{username} -> do
let content = getFileContent fc
key <- HashDigest . convert <$> DS.put content
runDB (setContent bookId username key)
return NoContent

18
backend/src/API/Catalogue.hs
View File

@ -24,8 +24,10 @@ import qualified Database.Channel as Channel
import GHC.TypeLits
import Servant hiding (contentType)
import Servant.Auth as SA
import qualified Servant.Docs as Docs
import Servant.XML
import Server.Auth
import System.IO.Unsafe (unsafePerformIO)
import Types
-- This is my first try on going to versioned apis, things might change
@ -40,7 +42,7 @@ newtype Rel = Rel { unRel :: Text } deriving (IsString, Show)
data Pagination = Pagination { previous :: Maybe Rel
, next :: Maybe Rel }
deriving (Show)
deriving (Show, Generic)
newtype SubSection = SubSection Rel deriving (Show)
newtype Acquisition = Acquisition Rel deriving (Show)
@ -64,6 +66,20 @@ deriving instance Show (Entry 1)
deriving instance Generic (Catalog 1)
deriving instance Generic (Entry 1)
instance Docs.ToSample (Entry 1) where
toSamples _ = [("Entry", EntryV1 "title" "identifier" docsTime "content" (Left (SubSection (Rel "sub"))))]
instance Docs.ToSample UTCTime where
toSamples _ = [("time", docsTime)]
instance Docs.ToSample Rel where
toSamples _ = [("Relative link", Rel "next")]
instance Docs.ToSample Pagination
instance Docs.ToSample (Catalog 1) -- where
-- toSamples _ = [("catalog", CatalogV1 docsTime (Rel "prev") (Rel "next") (Pagination (Just "previous") (Just "next")) [])]
docsTime :: UTCTime
docsTime = unsafePerformIO getCurrentTime
instance ToNode SubSection where
toNode (SubSection rel) = [xml|<link type="application/atom+xml;profile=opds-catalog;kind=acquisition" rel="subsection" href="#{unRel rel}">|]

41
backend/src/API/Channels.hs
View File

@ -1,23 +1,22 @@
{-# Language DataKinds #-}
{-# Language TypeFamilies #-}
{-# Language TypeOperators #-}
{-# Language NoImplicitPrelude #-}
{-# Language MultiParamTypeClasses #-}
{-# Language OverloadedStrings #-}
{-# Language TemplateHaskell #-}
{-# Language QuasiQuotes #-}
{-# Language RecordWildCards #-}
{-# Language DeriveGeneric #-}
{-# Language FlexibleInstances #-}
{-# Language TypeApplications #-}
{-# Language DataKinds #-}
{-# Language DuplicateRecordFields #-}
{-# Language NamedFieldPuns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module API.Channels (API, handler, JsonChannel(..)) where
import ClassyPrelude
import Control.Lens
import Control.Monad.Catch (throwM, MonadThrow)
import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.Logger
import Data.Aeson
import Data.Generics.Product
@ -25,6 +24,7 @@ import Database
import Database.Channel
import Servant
import Servant.Auth as SA
import qualified Servant.Docs as Docs
import Server.Auth
import Types
@ -36,6 +36,12 @@ data UpdateChannel = UpdateChannel { identifier :: ChannelID
, visibility :: Visibility }
deriving (Show, Generic)
instance Docs.ToSample JsonChannel where
toSamples _ = [("Channel", JsonChannel "channel" Private)]
instance Docs.ToSample UpdateChannel where
toSamples _ = [("Channel", UpdateChannel 13 "channel" Private)]
instance ToJSON JsonChannel
instance FromJSON JsonChannel
instance ToJSON UpdateChannel
@ -43,6 +49,9 @@ instance FromJSON UpdateChannel
type API = Auth '[SA.BasicAuth, SA.Cookie, SA.JWT] SafeUser :> BaseAPI
instance Docs.ToCapture (Capture "channel_id" ChannelID) where
toCapture _ = Docs.DocCapture "channel_id" "The channel id"
type BaseAPI = "channels" :> ReqBody '[JSON] JsonChannel :> Post '[JSON] UpdateChannel
:<|> "channels" :> Capture "channel_id" ChannelID :> ReqBody '[JSON] UpdateChannel :> Put '[JSON] UpdateChannel
:<|> "channels" :> Get '[JSON] [JsonChannel]

6
backend/src/API/Users.hs
View File

@ -16,6 +16,7 @@ import Database.User
import Servant
import Servant.Auth as SA
import Servant.Auth.Server as SAS
import qualified Servant.Docs as Docs
import Server.Auth
import Types
import Web.FormUrlEncoded
@ -27,12 +28,17 @@ data RegisterForm = RegisterForm { username :: Username
, passwordAgain :: PlainPassword }
deriving (Generic, Show)
instance Docs.ToSample RegisterForm
data LoginStatus = LoginStatus ( Maybe SafeUser ) deriving Generic
data RegisterStatus = RegisterStatus deriving Generic
instance Docs.ToSample RegisterStatus
instance ToJSON LoginStatus
instance FromJSON LoginStatus
instance Docs.ToSample LoginStatus
instance FromJSON RegisterForm
instance ToJSON RegisterForm

33
backend/src/Database/Schema.hs
View File

@ -1,16 +1,16 @@
{-# Language NoImplicitPrelude #-}
{-# Language DeriveGeneric #-}
{-# Language OverloadedStrings #-}
{-# Language DuplicateRecordFields #-}
{-# Language GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Database.Schema where
import ClassyPrelude
import Database.Selda.Generic
import Data.Aeson
import Database.Selda
import Database.Selda.Backend
import Data.Aeson
import Database.Selda.Generic
import qualified Servant.Docs as Docs
import Web.HttpApiData
-- | User type
@ -18,9 +18,18 @@ newtype PlainPassword = PlainPassword Text deriving (Show, ToJSON, FromJSON, ToH
newtype HashedPassword = HashedPassword {unHashed :: ByteString}
data NoPassword = NoPassword
newtype Email = Email { unEmail :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Generic, Eq)
newtype Email = Email { unEmail :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Generic, Eq, IsString)
newtype Username = Username { unUsername :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Eq, Generic)
newtype Username = Username { unUsername :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Eq, Generic, IsString)
instance Docs.ToSample Username where
toSamples _ = [("Username", Username "user123")]
instance Docs.ToSample Email where
toSamples _ = [("Email", Email "first.last@example.com")]
instance Docs.ToSample PlainPassword where
toSamples _ = [("Password", PlainPassword "password123")]
instance SqlType HashedPassword where
mkLit = LCustom . LBlob . unHashed
@ -42,9 +51,9 @@ instance SqlType Username where
newtype UserID = UserID {unUserID :: Int} deriving (Show)
newtype BookID = BookID {unBookID :: Int} deriving (Show, ToJSON, FromJSON, FromHttpApiData, Eq, Ord, ToHttpApiData, Generic)
newtype BookID = BookID {unBookID :: Int} deriving (Show, ToJSON, FromJSON, FromHttpApiData, Eq, Ord, ToHttpApiData, Generic, Num)
newtype ChannelID = ChannelID {unChannelID :: Int} deriving (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON, Eq, Generic)
newtype ChannelID = ChannelID {unChannelID :: Int} deriving (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON, Eq, Generic, Num)
newtype TagID = TagID {unTagID :: Int} deriving (Show)

50
backend/src/Server.hs
View File

@ -1,37 +1,45 @@
{-# Language DataKinds #-}
{-# Language TypeFamilies #-}
{-# Language TypeOperators #-}
{-# Language NoImplicitPrelude #-}
{-# Language MultiParamTypeClasses #-}
{-# Language OverloadedStrings #-}
{-# Language TemplateHaskell #-}
{-# Language QuasiQuotes #-}
{-# Language RecordWildCards #-}
{-# Language DeriveGeneric #-}
{-# Language FlexibleInstances #-}
{-# Language TypeApplications #-}
{-# Language ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Server where
import qualified API as API
import Server.Auth (authCheck)
import Servant
import Types
import ClassyPrelude hiding (Handler)
import Control.Monad.Logger
import Control.Monad.Except
import Servant.Auth.Server as SAS
import Control.Lens
import Control.Monad.Except
import Control.Monad.Logger
import Data.Generics.Product
import Servant
import Servant.Auth.Docs ()
import Servant.Auth.Server as SAS
import qualified Servant.Docs as Docs
import Servant.HTML.Lucid (HTML)
import Server.Auth (SafeUser)
import Server.Auth (authCheck)
import Types
type API = API.API :<|> "static" :> Raw
type API = API.API
:<|> "help" :> Get '[PlainText, HTML] String
:<|> "static" :> Raw
type Ctx = '[BasicAuthData -> IO (AuthResult SafeUser), CookieSettings, JWTSettings]
server :: App -> Application
server app = serveWithContext api cfg (hoistServerWithContext (Proxy @ API.API) (Proxy @ Ctx) server' API.handler :<|> serveDirectoryFileServer "static")
server app = serveWithContext api cfg (hoistServerWithContext (Proxy @ API.API) (Proxy @ Ctx) server' API.handler :<|> serveDocs :<|> serveDirectoryFileServer "static")
where
apiDocs :: Docs.API
apiDocs = Docs.docs (Proxy @API.API)
serveDocs = pure $ Docs.markdown apiDocs
myKey = view (field @"jwk") app
jwtCfg = defaultJWTSettings myKey
authCfg = authCheck app

22
backend/src/Server/Auth.hs
View File

@ -1,11 +1,11 @@
{-# Language DataKinds #-}
{-# Language TypeFamilies #-}
{-# Language OverloadedStrings #-}
{-# Language NoImplicitPrelude #-}
{-# Language TypeOperators #-}
{-# Language DuplicateRecordFields #-}
{-# Language TypeApplications #-}
{-# Language TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Server.Auth
( SafeUser(..)
, authCheck
@ -15,8 +15,8 @@ module Server.Auth
import ClassyPrelude
import Control.Lens (view)
import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.Logger
import Control.Monad.Catch (throwM, MonadThrow)
import Data.Aeson
import Data.Generics.Product
import Database
@ -24,6 +24,7 @@ import Database.Schema
import Database.User
import Servant (err401)
import Servant.Auth.Server as SAS
import qualified Servant.Docs as Docs
import Types
-- generic-lens can convert similar types to this
@ -36,6 +37,9 @@ data SafeUser = SafeUser { email :: Email
, role :: Role }
deriving (Show, Generic)
instance Docs.ToSample SafeUser where
toSamples _ = [("User", SafeUser "user@example.com" "user" UserRole )]
instance ToJSON SafeUser where
instance FromJSON SafeUser where
instance ToJWT SafeUser where

1
migrations/V1.2__unique_tags.sql Normal file
View File

@ -0,0 +1 @@
create unique index tag_owner on tags (tag, owner);