Fix warnings
This commit is contained in:
parent
0c0606506a
commit
bd5feb8353
233
.stylish-haskell.yaml
Normal file
233
.stylish-haskell.yaml
Normal file
@ -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'.
|
||||
#
|
||||
# - <integer>: 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
|
@ -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,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
|
||||
|
@ -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
|
||||
|
@ -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,8 +77,8 @@ 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
|
||||
@ -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
|
||||
|
@ -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]
|
||||
|
@ -1,14 +1,14 @@
|
||||
{-# 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.Schema
|
||||
|
@ -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
|
||||
|
@ -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 Configuration
|
||||
import Control.Lens (view)
|
||||
import Data.Generics.Product
|
||||
import Data.Pool (createPool)
|
||||
import Database.Selda.PostgreSQL (PGConnectInfo(..), pgOpen, seldaClose)
|
||||
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
|
||||
|
Loading…
Reference in New Issue
Block a user