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

Fix warnings

Browse Source
This commit is contained in:
Mats Rauhala
2019-01-21 21:47:58 +02:00
parent 0c0606506a
commit bd5feb8353
9 changed files with 295 additions and 65 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
backend/backend.cabal
View File

@ -17,6 +17,7 @@ cabal-version: >=1.10
executable backend
main-is: Main.hs
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
other-modules: Devel.Main
, API
, API.Books

13
backend/src/API.hs
View File

@ -13,18 +13,13 @@ module API (API, handler) where
import Servant
import Servant.HTML.Lucid (HTML)
import Types
import View
import qualified API.Books as Books
import qualified API.Catalogue as Catalogue
import qualified API.Channels as Channels
import qualified API.Users as Users
data Index = Index
type API = Users.API
:<|> "api" :> "current" :> Channels.API
:<|> "api" :> "current" :> Books.API
@ -38,11 +33,3 @@ handler = Users.handler
:<|> Catalogue.handler
:<|> Catalogue.handler
instance ToHtml Index where
toHtml _ = do
h1_ [class_ "title"] "Home page"
p_ [class_ "subtitle"] "Hello world"
toHtmlRaw = toHtml
indexHandler :: AppM (AppView Index)
indexHandler = mkView "Home" Index

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

@ -17,7 +17,7 @@ module API.Books where
import ClassyPrelude
import Control.Lens
import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.Catch (throwM)
import Control.Monad.Trans.Maybe
import Crypto.Hash (digestFromByteString)
import Data.Aeson
@ -63,8 +63,6 @@ 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

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

@ -17,7 +17,7 @@
module API.Catalogue (VersionedAPI, handler) where
import qualified API.Books
import ClassyPrelude
import ClassyPrelude hiding (link)
import Database
import Database.Book (Book(..))
import qualified Database.Channel as Channel
@ -46,15 +46,16 @@ data Pagination = Pagination { previous :: Maybe Rel
newtype SubSection = SubSection Rel deriving (Show)
newtype Acquisition = Acquisition Rel deriving (Show)
newtype Time = Time { getTime :: UTCTime } deriving Show
data instance Entry 1 = EntryV1 { title :: Text
, identifier :: Text
, updated :: UTCTime
, updated :: Time
, content :: Text
, link :: Either SubSection Acquisition
}
data instance Catalog 1 = CatalogV1 { updated :: UTCTime
data instance Catalog 1 = CatalogV1 { updated :: Time
, self :: Rel
, start :: Rel
, pagination :: Pagination
@ -68,7 +69,7 @@ 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
instance Docs.ToSample Time where
toSamples _ = [("time", docsTime)]
instance Docs.ToSample Rel where
toSamples _ = [("Relative link", Rel "next")]
@ -76,9 +77,9 @@ 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
docsTime :: Time
docsTime = Time $ 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}">|]
@ -91,7 +92,7 @@ instance ToNode (Entry 1) where
<entry>
<title>#{title}
<id>#{identifier}
<updated>#{iso8601 updated}
<updated>#{iso8601 $ getTime updated}
<content>#{content}
^{either toNode toNode link}
|]
@ -101,7 +102,7 @@ instance ToNode (Catalog 1) where
<feed xmlns="http://www.w3.org/2005/Atom" xmlns:opds="http://opds-spec.org/2010/catalog">
<id>#{unRel self}
<title>Give me a title
<updated>#{iso8601 updated}
<updated>#{iso8601 $ getTime updated}
<link type="application/atom+xml;profile=opds-catalog;kind=navigation" rel="self" href="#{unRel self}">
<link type="application/atom+xml;profile=opds-catalog;kind=navigation" rel="start" href="#{unRel start}">
$maybe n <- (next pagination)
@ -125,7 +126,7 @@ relUrl x = Rel ("/api/current/" <> (pack . uriPath . linkURI $ x))
getBooksV1 :: Channel.ChannelID -> SafeUser -> AppM (Catalog 1)
getBooksV1 channelID SafeUser{username} = do
updated <- liftIO getCurrentTime
updated <- Time <$> liftIO getCurrentTime
let self = relUrl selfUrl
start = relUrl startUrl
selfUrl = safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) channelID
@ -142,7 +143,7 @@ getBooksV1 channelID SafeUser{username} = do
getChannelsV1 :: SafeUser -> AppM (Catalog 1)
getChannelsV1 SafeUser{username} = do
updated <- liftIO getCurrentTime
updated <- Time <$> liftIO getCurrentTime
let self = relUrl selfUrl
-- I'm not sure if this safe link approach is really useable with this
-- api hierarchy since I can't access the topmost api from here. Also
@ -153,7 +154,7 @@ getChannelsV1 SafeUser{username} = do
entries <- map (fromChannel updated) <$> runDB (Channel.userChannels username)
pure CatalogV1{..}
where
fromChannel :: UTCTime -> Channel.Channel -> Entry 1
fromChannel :: Time -> Channel.Channel -> Entry 1
fromChannel updated Channel.Channel{..} =
let url = safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) identifier
self = relUrl url

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

@ -16,7 +16,7 @@ module API.Channels (API, handler, JsonChannel(..)) where
import ClassyPrelude
import Control.Lens
import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.Catch (throwM)
import Control.Monad.Logger
import Data.Aeson
import Data.Generics.Product
@ -49,9 +49,6 @@ 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]

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

@ -1,30 +1,30 @@
{-# Language DataKinds #-}
{-# Language TypeFamilies #-}
{-# Language OverloadedStrings #-}
{-# Language NoImplicitPrelude #-}
{-# Language TypeOperators #-}
{-# Language DuplicateRecordFields #-}
{-# Language TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module API.Users where
import ClassyPrelude
import Control.Monad.Catch (throwM, MonadThrow)
import Control.Monad.Catch (throwM)
import Data.Aeson
import Database (runDB)
import Database (runDB)
import Database.Schema
import Database.User
import Servant
import Servant.Auth as SA
import Servant.Auth as SA
import Servant.Auth.Server as SAS
import qualified Servant.Docs as Docs
import qualified Servant.Docs as Docs
import Server.Auth
import Types
import Web.FormUrlEncoded
data RegisterForm = RegisterForm { username :: Username
, email :: Email
, password :: PlainPassword
data RegisterForm = RegisterForm { username :: Username
, email :: Email
, password :: PlainPassword
, passwordAgain :: PlainPassword }
deriving (Generic, Show)
@ -56,7 +56,7 @@ handler = loginHandler :<|> registerHandler
loginHandler :: AuthResult SafeUser -> AppM LoginStatus
loginHandler (Authenticated u) = return (LoginStatus (Just u))
loginHandler _ = return (LoginStatus Nothing)
loginHandler _ = return (LoginStatus Nothing)
registerHandler :: RegisterForm -> AppM RegisterStatus
registerHandler RegisterForm{..} =

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

@ -3,6 +3,9 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Database.Schema where
import ClassyPrelude
@ -11,6 +14,7 @@ import Database.Selda
import Database.Selda.Backend
import Database.Selda.Generic
import qualified Servant.Docs as Docs
import Servant (Capture)
import Web.HttpApiData
-- | User type
@ -53,8 +57,14 @@ newtype UserID = UserID {unUserID :: Int} deriving (Show)
newtype BookID = BookID {unBookID :: Int} deriving (Show, ToJSON, FromJSON, FromHttpApiData, Eq, Ord, ToHttpApiData, Generic, Num)
instance Docs.ToCapture (Capture "book_id" BookID) where
toCapture _ = Docs.DocCapture "book_id" "The book id"
newtype ChannelID = ChannelID {unChannelID :: Int} deriving (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON, Eq, Generic, Num)
instance Docs.ToCapture (Capture "channel_id" ChannelID) where
toCapture _ = Docs.DocCapture "channel_id" "The channel id"
newtype TagID = TagID {unTagID :: Int} deriving (Show)
instance SqlType UserID where

39
backend/src/Main.hs
View File

@ -1,22 +1,24 @@
{-# Language OverloadedStrings #-}
{-# Language RecordWildCards #-}
{-# Language DuplicateRecordFields #-}
{-# Language TypeApplications #-}
{-# Language DataKinds #-}
{-# Language NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module Main where
import Server (server)
import Network.Wai.Handler.Warp (run)
import Types
import Configuration
import Dhall (input, auto)
import ClassyPrelude
import Control.Lens (view)
import Data.Generics.Product
import Data.Pool (createPool)
import Database.Selda.PostgreSQL (PGConnectInfo(..), pgOpen, seldaClose)
import Servant.Auth.Server (generateKey)
import ClassyPrelude
import Configuration
import Control.Lens (view)
import Data.Generics.Product
import Data.Pool (createPool)
import Database.Selda.PostgreSQL (PGConnectInfo (..), pgOpen,
seldaClose)
import Dhall (auto, input)
import Network.Wai.Handler.Warp (run)
import Servant.Auth.Server (generateKey)
import Server (server)
import Types
import System.Environment (getEnvironment)
defaultMain :: App -> IO ()
defaultMain = run 8080 . server
@ -35,5 +37,6 @@ withApp config f = do
main :: IO ()
main = do
c <- input auto "./config/config.dhall"
path <- fmap pack . lookup "CONF" <$> getEnvironment
c <- input auto (fromMaybe "./config/config.dhall" path)
withApp c defaultMain