Rewrite to use Scotty

barrucadu · Jan 26, 2020 · 0774a4a · 0774a4a
1 parent bb272df
commit 0774a4a
Show file tree

Hide file tree

Showing 20 changed files with 326 additions and 516 deletions.
diff --git a/README.md b/README.md
@@ -15,7 +15,6 @@ Running
 
 Configure with environment variables:
 
-- `BOOKDB_HOST`: host to listen on (default `*`)
 - `BOOKDB_PORT`: port to listen on (default `3000`)
 - `BOOKDB_WEB_ROOT`: base path for external URLs (default `http://localhost:3000`)
 - `BOOKDB_FILE_ROOT`: directory to store covers in (default `/tmp`)

diff --git a/bookdb.cabal b/bookdb.cabal
@@ -61,8 +61,6 @@ executable bookdb
                      , Handler.List
                      , Handler.Templates
                      , Handler.Utils
-                     , Routes
-                     , Requests
                      , Types
 
   -- LANGUAGE extensions used by modules in this package.
@@ -79,6 +77,7 @@ executable bookdb
                      , mtl
                      , network
                      , random
+                     , scotty
                      , selda
                      , selda-postgresql
                      , shakespeare
@@ -88,10 +87,6 @@ executable bookdb
                      , wai
                      , wai-extra
                      , wai-middleware-static
-                     , warp
-                     , web-routes
-                     , web-routes-th
-                     , web-routes-wai
 
   -- Directories containing source files.
   hs-source-dirs:      src

diff --git a/src/Configuration.hs b/src/Configuration.hs
@@ -6,24 +6,22 @@ module Configuration where
 import           Control.Monad             (guard)
 import           Data.Maybe                (fromMaybe)
 import qualified Data.Text                 as T
-import           Database.Selda.PostgreSQL (PGConnectInfo(..))
+import           Database.Selda.PostgreSQL (PGConnectInfo (..))
 import           System.Environment        (lookupEnv)
 import           Text.Read                 (readMaybe)
 
 -- | The configuration record.
 data Configuration = Configuration
-  { cfgHost     :: String
-  , cfgPort     :: Int
-  , cfgWebRoot  :: String
-  , cfgFileRoot :: String
+  { cfgPort     :: Int
+  , cfgWebRoot  :: T.Text -- everything which consumes this takes a Text
+  , cfgFileRoot :: String -- everything which consumes this takes a String - inconsistency ho!
   , cfgDatabase :: PGConnectInfo
   , cfgReadOnly :: Bool
   }
 
 -- | Read configuration from the environment.
 getConfig :: IO (Either [String] Configuration)
 getConfig = do
-  bookdb_host <- lookupEnv "BOOKDB_HOST"
   bookdb_port <- lookupEnv "BOOKDB_PORT"
   bookdb_web_root <- lookupEnv "BOOKDB_WEB_ROOT"
   bookdb_file_root <- lookupEnv "BOOKDB_FILE_ROOT"
@@ -36,9 +34,8 @@ getConfig = do
   bookdb_read_only <- lookupEnv "BOOKDB_READ_ONLY"
 
   pure . runValidation $ Configuration
-    <$> pure (fromMaybe "*" bookdb_host)
-    <*> maybeToValidation "could not parse BOOKDB_PORT (expected integer in range 0..65535)" (maybe (Just 3000) readPort bookdb_port)
-    <*> pure (fromMaybe "http://localhost:3000" bookdb_web_root)
+    <$> maybeToValidation "could not parse BOOKDB_PORT (expected integer in range 0..65535)" (maybe (Just 3000) readPort bookdb_port)
+    <*> pure (maybe "http://localhost:3000" T.pack bookdb_web_root)
     <*> pure (fromMaybe "/tmp" bookdb_file_root)
     <*> (PGConnectInfo
          <$> pure (maybe "localhost" T.pack bookdb_pg_host)

diff --git a/src/Database.hs b/src/Database.hs
@@ -1,27 +1,29 @@
-{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedLabels  #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -Wno-missing-signatures #-}
 
 module Database (module Database, module Types) where
 
-import           Control.Monad          (unless)
-import           Data.Maybe             (listToMaybe)
-import           Data.Monoid            ((<>))
-import           Data.Text              (Text)
+import           Control.Monad                (unless)
+import           Data.Maybe                   (listToMaybe)
+import           Data.Monoid                  ((<>))
+import           Data.Text                    (Text)
 import           Database.Selda
+import           Database.Selda.MakeSelectors
 
 import           Types
 
 -- | The table of books.
 books :: Table Book
-books = table "books" [#bookIsbn :- primary, #bookCategoryCode :- foreignKey categories dbCode]
+(books, dbIsbn :*: dbTitle :*: dbSubtitle :*: dbCover :*: dbVolume :*: dbFascicle :*: dbVoltitle :*: dbAuthor :*: dbTranslator :*: dbEditor :*: dbSorting :*: dbRead :*: dbLastRead :*: dbLocation :*: dbBorrower :*: dbCategoryCode)
+  = tableWithSelectors "books" [#bookIsbn :- primary, #bookCategoryCode :- foreignKey categories dbCode]
 
 -- | The table of categories
 categories :: Table BookCategory
-categories = table "book_categories" [#categoryCode :- primary]
+(categories, dbCode :*: dbName) = tableWithSelectors "book_categories" [#categoryCode :- primary]
 
 -- | Create the tables
-makedb :: SeldaM ()
+makedb :: SeldaM db ()
 makedb = do
     createTable categories
     insert_ categories defaultCategories
@@ -43,24 +45,19 @@ makedb = do
       , uncategorised
       ]
 
--- selectors
-dbIsbn :*: dbTitle :*: dbSubtitle :*: dbCover :*: dbVolume :*: dbFascicle :*: dbVoltitle :*: dbAuthor :*: dbTranslator :*: dbEditor :*: dbSorting :*: dbRead :*: dbLastRead :*: dbLocation :*: dbBorrower :*: dbCategoryCode = selectors books
-
-dbCode :*: dbName = selectors categories
-
 -------------------------------------------------------------------------------
 -- * Queries
 
 -- | All books.
-allBooks :: SeldaM [Book]
+allBooks :: SeldaM db [Book]
 allBooks = query (select books)
 
 -- | All categories.
-allCategories :: SeldaM [BookCategory]
+allCategories :: SeldaM db [BookCategory]
 allCategories = query (select categories)
 
 -- | Find a book by ISBN.
-findBook :: Text -> SeldaM (Maybe Book)
+findBook :: Text -> SeldaM db (Maybe Book)
 findBook isbn = do
   results <- query $ do
     b <- select books
@@ -69,17 +66,17 @@ findBook isbn = do
   pure (listToMaybe results)
 
 -- | Insert a book.
-insertBook :: Book -> SeldaM ()
+insertBook :: Book -> SeldaM db ()
 insertBook b = insert_ books [b]
 
 -- | Replace a book by ISBN.
-replaceBook :: Text -> Book -> SeldaM ()
+replaceBook :: Text -> Book -> SeldaM db ()
 replaceBook isbn b = transaction $ do
   deleteBook isbn
   insertBook b
 
 -- | Delete a book by ISBN.
-deleteBook :: Text -> SeldaM ()
+deleteBook :: Text -> SeldaM db ()
 deleteBook isbn = deleteFrom_ books (\b -> b ! dbIsbn .== literal isbn)
 
 -- | Search the books.
@@ -93,7 +90,7 @@ searchBooks
   -> Maybe BookCategory -- ^ Category (exact match)
   -> Bool -- ^ Permit read books
   -> Bool -- ^ Permit unread books
-  -> SeldaM [Book]
+  -> SeldaM db [Book]
 searchBooks isbn title subtitle author location borrower category matchread matchunread = query $ do
   b <- select books
   let l s = literal ("%" <> s <> "%")
@@ -115,7 +112,7 @@ searchBooks isbn title subtitle author location borrower category matchread matc
   pure b
 
 -- | Limited form of search: use the given restriction.
-restrictBooks :: (Row s Book -> Col s Bool) -> SeldaM [Book]
+restrictBooks :: (Row db Book -> Col db Bool) -> SeldaM db [Book]
 restrictBooks f = query $ do
   b <- select books
   restrict (f b)

diff --git a/src/Handler/Edit.hs b/src/Handler/Edit.hs
@@ -12,116 +12,116 @@ module Handler.Edit
     , commitDelete
     ) where
 
-import           Prelude                   hiding (null, userError)
-
-import           Control.Applicative       ((<|>))
-import           Control.Monad.IO.Class    (liftIO)
-import           Control.Monad.Trans.Class (lift)
-import           Data.Char                 (chr)
-import           Data.List                 (sort)
-import           Data.Text                 (Text, intercalate, null, pack,
-                                            splitOn, unpack)
-import           Data.Time.Calendar        (fromGregorian)
-import           Data.Time.Clock           (UTCTime (..))
+import           Prelude                    hiding (null, userError)
+
+import           Control.Applicative        ((<|>))
+import           Control.Monad.IO.Class     (MonadIO, liftIO)
+import           Control.Monad.Trans.Class  (lift)
+import           Control.Monad.Trans.Reader (ask)
+import qualified Data.ByteString            as B
+import qualified Data.ByteString.Lazy       as BL
+import           Data.Char                  (chr)
+import           Data.List                  (sort)
+import           Data.Text                  (Text, intercalate, null, pack,
+                                             splitOn, unpack)
+import           Data.Time.Calendar         (fromGregorian)
+import           Data.Time.Clock            (UTCTime (..))
 import           Database
-import           System.FilePath           (joinPath, takeExtension,
-                                            takeFileName)
-import           Text.Read                 (readMaybe)
+import           Network.Wai.Parse          (FileInfo (..))
+import           System.FilePath            (joinPath, takeExtension,
+                                             takeFileName)
+import           Text.Read                  (readMaybe)
+import qualified Web.Scotty.Trans           as S
 
 import           Configuration
 import           Handler.Information
+import qualified Handler.Templates          as T
 import           Handler.Utils
-import           Requests
-import           Routes
-
-import qualified Data.ByteString           as B
-import qualified Data.ByteString.Lazy      as BL
-import qualified Handler.Templates         as T
 
 -- |Display an add form, or an error if in read-only mode
-add :: Handler Sitemap
+add :: Handler db
 add = onReadWrite add'
 
 -- |Display an edit form, or an error if in read-only mode
 edit :: Text -- ^ The ISBN
-     -> Handler Sitemap
+     -> Handler db
 edit = onReadWrite . withBook edit'
 
 -- |Display a confirm delete page, or an error if in read-only mode
 delete :: Text -- ^ The ISBN
-       -> Handler Sitemap
+       -> Handler db
 delete = onReadWrite . withBook delete'
 
 -- |Commit an add, or display an error if in read-only mode
-commitAdd :: Handler Sitemap
+commitAdd :: Handler db
 commitAdd = onReadWrite commitAdd'
 
 -- |Commit an edit, or display an error if in read-only mode
 commitEdit :: Text -- ^ The ISBN
-           -> Handler Sitemap
+           -> Handler db
 commitEdit = onReadWrite . withBook commitEdit'
 
 -- |Commit a delete, or display an error if in read-only mode
 commitDelete :: Text -- ^ The ISBN
-             -> Handler Sitemap
+             -> Handler db
 commitDelete = onReadWrite . withBook commitDelete'
 
 -------------------------
 
-add' :: Handler Sitemap
+add' :: Handler db
 add' = do
-  categories <- lift allCategories
-  htmlUrlResponse $ T.addForm categories
+  categories <- lift (lift allCategories)
+  htmlResponse $ T.addForm categories
 
-edit' :: Book -> Handler Sitemap
+edit' :: Book -> Handler db
 edit' book = do
-  categories <- lift allCategories
-  htmlUrlResponse $ T.editForm categories book
+  categories <- lift (lift allCategories)
+  htmlResponse $ T.editForm categories book
 
-delete' :: Book -> Handler Sitemap
-delete' book = htmlUrlResponse $ T.confirmDelete book
+delete' :: Book -> Handler db
+delete' book = htmlResponse $ T.confirmDelete book
 
 -------------------------
 
-commitAdd' :: Handler Sitemap
+commitAdd' :: Handler db
 commitAdd' = mutate Nothing
 
-commitEdit' :: Book -> Handler Sitemap
+commitEdit' :: Book -> Handler db
 commitEdit' = mutate . Just
 
-commitDelete' :: Book -> Handler Sitemap
+commitDelete' :: Book -> Handler db
 commitDelete' book = do
-  lift (deleteBook (bookIsbn book))
+  lift (lift (deleteBook (bookIsbn book)))
   information "Book deleted successfully"
 
 -------------------------
 
 -- |Mutate a book, and display a notification when done.
 mutate :: Maybe Book -- ^ The book to mutate, or Nothing to insert
-       -> Handler Sitemap
+       -> Handler db
 mutate book = do
   -- do cover upload
   cover      <- uploadCover
-  isbn       <- param' "isbn"       ""
-  title      <- param' "title"      ""
-  subtitle   <- param' "subtitle"   ""
-  volume     <- param' "volume"     ""
-  fascicle   <- param' "fascicle"   ""
-  voltitle   <- param' "voltitle"   ""
-  author     <- param' "author"     ""
-  translator <- param' "translator" ""
-  editor     <- param' "editor"     ""
-  sorting    <- param' "sorting"    ""
-  read       <- param' "read"       ""
-  lastread   <- param' "lastread"   ""
-  location   <- param' "location"   ""
-  code       <- param' "category"   "-"
-  borrower   <- param' "borrower"   ""
+  isbn       <- paramWithDefault "isbn"       ""
+  title      <- paramWithDefault "title"      ""
+  subtitle   <- paramWithDefault "subtitle"   ""
+  volume     <- paramWithDefault "volume"     ""
+  fascicle   <- paramWithDefault "fascicle"   ""
+  voltitle   <- paramWithDefault "voltitle"   ""
+  author     <- paramWithDefault "author"     ""
+  translator <- paramWithDefault "translator" ""
+  editor     <- paramWithDefault "editor"     ""
+  sorting    <- paramWithDefault "sorting"    ""
+  read       <- paramWithDefault "read"       ""
+  lastread   <- paramWithDefault "lastread"   ""
+  location   <- paramWithDefault "location"   ""
+  code       <- paramWithDefault "category"   "-"
+  borrower   <- paramWithDefault "borrower"   ""
 
   if null isbn || null title || null author || null location
   then userError "Missing required fields"
   else do
-    categories <- lift allCategories
+    categories <- lift (lift allCategories)
 
     let cover'      = cover <|> (book >>= bookCover)
     let author'     = sortAuthors author
@@ -136,10 +136,10 @@ mutate book = do
 
         case book of
           Just b -> do
-            lift (replaceBook (bookIsbn b) newbook)
+            lift (lift (replaceBook (bookIsbn b) newbook))
             information "Book updated successfully"
           Nothing -> do
-            lift (insertBook newbook)
+            lift (lift (insertBook newbook))
             information "Book added successfully"
 
       (Nothing, _) -> userError "Invalid date format, expected yyyy-mm-dd"
@@ -166,10 +166,10 @@ mutate book = do
 -------------------------
 
 -- |Upload the cover image for a book, returning its path
-uploadCover :: RequestProcessor Sitemap (Maybe Text)
+uploadCover :: MonadIO m => RequestProcessor db m (Maybe Text)
 uploadCover = do
-  isbn <- param' "isbn" ""
-  file <- lookup "cover" <$> askFiles
+  isbn <- paramWithDefault "isbn" ""
+  file <- lookup "cover" <$> S.files
 
   case file of
     Just f@(FileInfo _ _ c)
@@ -179,7 +179,7 @@ uploadCover = do
 
   where
   save fbits (FileInfo name _ content) = do
-    fileroot <- cfgFileRoot <$> askConf
+    fileroot <- cfgFileRoot <$> lift ask
     let ext    = takeExtension (map (chr . fromIntegral) $ B.unpack name)
     let path   = joinPath $ fileroot : fbits
     let fname' = path ++ ext