diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 0000000..7a900fc --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,233 @@ +# stylish-haskell configuration file +# ================================== + +# The stylish-haskell tool is mainly configured by specifying steps. These steps +# are a list, so they have an order, and one specific step may appear more than +# once (if needed). Each file is processed by these steps in the given order. +steps: + # Convert some ASCII sequences to their Unicode equivalents. This is disabled + # by default. + # - unicode_syntax: + # # In order to make this work, we also need to insert the UnicodeSyntax + # # language pragma. If this flag is set to true, we insert it when it's + # # not already present. You may want to disable it if you configure + # # language extensions using some other method than pragmas. Default: + # # true. + # add_language_pragma: true + + # Align the right hand side of some elements. This is quite conservative + # and only applies to statements where each element occupies a single + # line. + - simple_align: + cases: true + top_level_patterns: true + records: true + + # Import cleanup + - imports: + # There are different ways we can align names and lists. + # + # - global: Align the import names and import list throughout the entire + # file. + # + # - file: Like global, but don't add padding when there are no qualified + # imports in the file. + # + # - group: Only align the imports per group (a group is formed by adjacent + # import lines). + # + # - none: Do not perform any alignment. + # + # Default: global. + align: global + + # The following options affect only import list alignment. + # + # List align has following options: + # + # - after_alias: Import list is aligned with end of import including + # 'as' and 'hiding' keywords. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_alias: Import list is aligned with start of alias or hiding. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - new_line: Import list starts always on new line. + # + # > import qualified Data.List as List + # > (concat, foldl, foldr, head, init, last, length) + # + # Default: after_alias + list_align: after_alias + + # Right-pad the module names to align imports in a group: + # + # - true: a little more readable + # + # > import qualified Data.List as List (concat, foldl, foldr, + # > init, last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # - false: diff-safe + # + # > import qualified Data.List as List (concat, foldl, foldr, init, + # > last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # Default: true + pad_module_names: true + + # Long list align style takes effect when import is too long. This is + # determined by 'columns' setting. + # + # - inline: This option will put as much specs on same line as possible. + # + # - new_line: Import list will start on new line. + # + # - new_line_multiline: Import list will start on new line when it's + # short enough to fit to single line. Otherwise it'll be multiline. + # + # - multiline: One line per import list entry. + # Type with constructor list acts like single import. + # + # > import qualified Data.Map as M + # > ( empty + # > , singleton + # > , ... + # > , delete + # > ) + # + # Default: inline + long_list_align: inline + + # Align empty list (importing instances) + # + # Empty list align has following options + # + # - inherit: inherit list_align setting + # + # - right_after: () is right after the module name: + # + # > import Vector.Instances () + # + # Default: inherit + empty_list_align: inherit + + # List padding determines indentation of import list on lines after import. + # This option affects 'long_list_align'. + # + # - : constant value + # + # - module_name: align under start of module name. + # Useful for 'file' and 'group' align settings. + list_padding: 4 + + # Separate lists option affects formatting of import list for type + # or class. The only difference is single space between type and list + # of constructors, selectors and class functions. + # + # - true: There is single space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable (fold, foldl, foldMap)) + # + # - false: There is no space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable(fold, foldl, foldMap)) + # + # Default: true + separate_lists: true + + # Space surround option affects formatting of import lists on a single + # line. The only difference is single space after the initial + # parenthesis and a single space before the terminal parenthesis. + # + # - true: There is single space associated with the enclosing + # parenthesis. + # + # > import Data.Foo ( foo ) + # + # - false: There is no space associated with the enclosing parenthesis + # + # > import Data.Foo (foo) + # + # Default: false + space_surround: false + + # Language pragmas + - language_pragmas: + # We can generate different styles of language pragma lists. + # + # - vertical: Vertical-spaced language pragmas, one per line. + # + # - compact: A more compact style. + # + # - compact_line: Similar to compact, but wrap each line with + # `{-#LANGUAGE #-}'. + # + # Default: vertical. + style: vertical + + # Align affects alignment of closing pragma brackets. + # + # - true: Brackets are aligned in same column. + # + # - false: Brackets are not aligned together. There is only one space + # between actual import and closing bracket. + # + # Default: true + align: true + + # stylish-haskell can detect redundancy of some language pragmas. If this + # is set to true, it will remove those redundant pragmas. Default: true. + remove_redundant: true + + # Replace tabs by spaces. This is disabled by default. + # - tabs: + # # Number of spaces to use for each tab. Default: 8, as specified by the + # # Haskell report. + # spaces: 8 + + # Remove trailing whitespace + - trailing_whitespace: {} + + # Squash multiple spaces between the left and right hand sides of some + # elements into single spaces. Basically, this undoes the effect of + # simple_align but is a bit less conservative. + # - squash: {} + +# A common setting is the number of columns (parts of) code will be wrapped +# to. Different steps take this into account. Default: 80. +columns: 80 + +# By default, line endings are converted according to the OS. You can override +# preferred format here. +# +# - native: Native newline format. CRLF on Windows, LF on other OSes. +# +# - lf: Convert to LF ("\n"). +# +# - crlf: Convert to CRLF ("\r\n"). +# +# Default: native. +newline: native + +# Sometimes, language extensions are specified in a cabal file or from the +# command line instead of using language pragmas in the file. stylish-haskell +# needs to be aware of these, so it can parse the file correctly. +# +# No language extensions are enabled by default. +language_extensions: + - DeriveGeneric + - NoImplicitPrelude + - OverloadedStrings + - RecordWildCards + # - TemplateHaskell + # - QuasiQuotes diff --git a/backend/backend.cabal b/backend/backend.cabal index 9ca8765..2e53635 100644 --- a/backend/backend.cabal +++ b/backend/backend.cabal @@ -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 diff --git a/backend/src/API.hs b/backend/src/API.hs index ceb52c7..50ef49c 100644 --- a/backend/src/API.hs +++ b/backend/src/API.hs @@ -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 diff --git a/backend/src/API/Books.hs b/backend/src/API/Books.hs index bb13e42..52d778b 100644 --- a/backend/src/API/Books.hs +++ b/backend/src/API/Books.hs @@ -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 diff --git a/backend/src/API/Catalogue.hs b/backend/src/API/Catalogue.hs index 13563fa..0e62492 100644 --- a/backend/src/API/Catalogue.hs +++ b/backend/src/API/Catalogue.hs @@ -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||] @@ -91,7 +92,7 @@ instance ToNode (Entry 1) where #{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 diff --git a/backend/src/API/Channels.hs b/backend/src/API/Channels.hs index 38de049..c698688 100644 --- a/backend/src/API/Channels.hs +++ b/backend/src/API/Channels.hs @@ -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] diff --git a/backend/src/API/Users.hs b/backend/src/API/Users.hs index 8bddd5a..dd493e3 100644 --- a/backend/src/API/Users.hs +++ b/backend/src/API/Users.hs @@ -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{..} = diff --git a/backend/src/Database/Schema.hs b/backend/src/Database/Schema.hs index 8e3fdae..826290c 100644 --- a/backend/src/Database/Schema.hs +++ b/backend/src/Database/Schema.hs @@ -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 diff --git a/backend/src/Main.hs b/backend/src/Main.hs index a1ce581..83c972b 100644 --- a/backend/src/Main.hs +++ b/backend/src/Main.hs @@ -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