Move the API definition into its own module

Removes the generated file tutor.cabal

.gitignore

@@ -8,3 +8,6 @@ tmp/
 *.egg
 build
 htmlcov
+
+.stack-work/
+tutor.cabal

app/Main.hs

@@ -1,8 +1,8 @@
 module Main where
 
-import Lib
 import Data.Maybe
 import System.Environment
+import Tutor
 
 main :: IO ()
 main = do

package.yaml

@@ -46,6 +46,7 @@ executables:
     - -threaded
     - -rtsopts
     - -with-rtsopts=-N
+    - -Wall
     dependencies:
     - base
     - tutor
@@ -58,6 +59,7 @@ tests:
     - -threaded
     - -rtsopts
     - -with-rtsopts=-N
+    - -Wall
     dependencies:
     - base
     - tutor

src/Lib.hs

@@ -1,441 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Lib
-  ( startApp,
-    app,
-  )
-where
-
-import Control.Lens
-import qualified Control.Lens as Database.SQLite
-import Control.Monad.IO.Class
-import Data.Aeson
-import Data.Aeson.TH
-import qualified Data.List as L
-import Data.Maybe
-import Data.OpenApi
-  ( HasDescription (description),
-    HasInfo (info),
-    HasLicense (license),
-    HasTitle (title),
-    HasUrl (url),
-    HasVersion (version),
-    OpenApi,
-    ToSchema,
-    URL (URL),
-  )
-import qualified Data.Set as S
-import qualified Data.Text as T
-import Data.Typeable (Typeable)
-import Data.UUID
-import Data.Version (showVersion)
-import Database.SQLite.Simple
-import Database.SQLite.Simple.FromField
-import Database.SQLite.Simple.Internal
-import Database.SQLite.Simple.Ok
-import Database.SQLite.Simple.QQ
-import GHC.Generics
-import Network.Wai
-import Network.Wai.Handler.Warp
-import Network.Wai.Logger
-import qualified Paths_tutor as PT
-import Search
-import SearchParser
-import Select
-import Servant
-  ( Description,
-    Get,
-    Handler,
-    JSON,
-    Proxy (..),
-    QueryParam',
-    Raw,
-    Server,
-    Summary,
-    serve,
-    serveDirectoryFileServer,
-    type (:<|>) (..),
-    type (:>),
-  )
-import Servant.OpenApi (HasOpenApi (toOpenApi))
-
-instance FromField UUID where
-  fromField (Field (SQLText txt) _) = Ok $ fromMaybe nil $ fromText txt
-  fromField f = returnError ConversionFailed f "need a text"
-
-data Status = Status
-  {apiVersion :: T.Text}
-  deriving (Generic, Typeable)
-
-instance FromJSON Status
-
-instance ToJSON Status
-
-instance ToSchema Status
-
-data Prices = Prices
-  { usd :: Maybe T.Text,
-    usd_foil :: Maybe T.Text,
-    eur :: Maybe T.Text,
-    eur_foil :: Maybe T.Text,
-    tix :: Maybe T.Text
-  }
-  deriving (Eq, Show, Generic, Typeable)
-
-instance FromJSON Prices
-
-instance ToJSON Prices
-
-instance ToSchema Prices
-
-data Card = Card
-  { scryfall_id :: UUID,
-    name :: T.Text,
-    set_code :: T.Text,
-    collector_number :: T.Text,
-    rarity :: T.Text,
-    color_identity :: T.Text,
-    oracle_text :: Maybe T.Text,
-    prices :: Prices
-  }
-  deriving (Eq, Show, Generic, Typeable)
-
-instance FromJSON Card
-
-instance ToJSON Card
-
-instance ToSchema Card
-
-instance FromRow Card where
-  fromRow = do
-    scryfall_id <- field
-    name <- field
-    set_code <- field
-    collector_number <- field
-    rarity <- field
-    color_identity <- field
-    oracle_text <- field
-    price_usd <- field
-    price_usd_foil <- field
-    price_eur <- field
-    price_eur_foil <- field
-    price_tix <- field
-    return $
-      Card
-        { scryfall_id = scryfall_id,
-          name = name,
-          set_code = set_code,
-          collector_number = collector_number,
-          rarity = rarity,
-          color_identity = color_identity,
-          oracle_text = oracle_text,
-          prices =
-            Prices
-              { usd = price_usd,
-                usd_foil = price_usd_foil,
-                eur = price_eur,
-                eur_foil = price_eur_foil,
-                tix = price_tix
-              }
-        }
-
-type GetStatus =
-  Summary "Get API Status"
-    :> Description "Get the current running API version."
-    :> "api"
-    :> "status"
-    :> Get '[JSON] Status
-
-type SearchCards =
-  Summary "Search for cards in a collection"
-    :> Description
-         "Text in the query string will be used to filter cards having that text in their \n\
-         \name. Additionally, the keyword expressions below can be used to search for \n\
-         \cards with certain properties. \n\
-         \ \n\
-         \ \n\
-         \### Examples \n\
-         \ \n\
-         \`bolt` \n\
-         \: Find all cards with \"bolt\" in the name \n\
-         \ \n\
-         \`\"God of\"` \n\
-         \: Find all cards with \"God of\" in the name \n\
-         \ \n\
-         \`t:legendary t:creature c:jund` \n\
-         \: Find all legendary creatures with a color \n\
-         \    identity of red/blue/green \n\
-         \ \n\
-         \`color<=ubg` \n\
-         \: Find all spells that are blue, black, green, or any \n\
-         \    combination thereof. \n\
-         \ \n\
-         \`color:red set:stx rarity>=rare` \n\
-         \: Find all red cards in Strixhaven that are \n\
-         \    rare or mythic \n\
-         \ \n\
-         \`t:enchantment o:\"enters the battlefield\"` \n\
-         \: Find all enchantments with ETB \n\
-         \    effects \n\
-         \ \n\
-         \ \n\
-         \### Keywords \n\
-         \ \n\
-         \ \n\
-         \#### Colors \n\
-         \ \n\
-         \Keywords \n\
-         \: `c`, `color` \n\
-         \ \n\
-         \Operators \n\
-         \: `:` (matches), `>=` (greater than or equal to), `<=` (less than \n\
-         \    or equal to) \n\
-         \ \n\
-         \Matches cards of the chosen color or colors. \n\
-         \ \n\
-         \Single colors \n\
-         \: `w` or `white`, `u` or `blue`, `b` or `black, =g` or `green`, `r` or `red` \n\
-         \ \n\
-         \Any combination of abbreviated single colors \n\
-         \: e.g.: `rg`, `uw`, or `wubgr` \n\
-         \ \n\
-         \Ravnican guilds \n\
-         \: `boros` (white/red), `golgari` (green/black), `selesnya` \n\
-         \    (green/white), `dimir` (blue/black), `orzhov` (white/black), `izzet` \n\
-         \    (blue/red), `gruul` (red/green), `azorius` (white/blue), `rakdos` (black/red), \n\
-         \    `simic` (green/blue) \n\
-         \ \n\
-         \Alaran shards \n\
-         \: `bant` (white/green/blue), `esper` (blue/white/black), \n\
-         \    `grixis` (black/blue/red), `jund` (red/blue/green), `naya` (green/red/white) \n\
-         \ \n\
-         \Tarkirian wedges \n\
-         \: `abzan` (white/black/green), `jeskai` (white/blue/red), \n\
-         \    `sultai` (blue/black/green), `mardu` (white/black/red), `temur` \n\
-         \    (blue/red/green) \n\
-         \ \n\
-         \ \n\
-         \#### Sets \n\
-         \ \n\
-         \Keywords \n\
-         \: `s`, `set`, `e`, `expansion` \n\
-         \ \n\
-         \Operators \n\
-         \: `:` (matches) \n\
-         \ \n\
-         \ \n\
-         \#### Rarity \n\
-         \ \n\
-         \Keywords \n\
-         \: `r`, `rarity` \n\
-         \ \n\
-         \Operators \n\
-         \: `:` (matches), `>=` (greater than or equal to), `<=` (less than \n\
-         \    or equal to) \n\
-         \ \n\
-         \ \n\
-         \#### Type \n\
-         \ \n\
-         \Keywords \n\
-         \: `t`, `type` \n\
-         \ \n\
-         \Operators \n\
-         \: `:` (matches) \n\
-         \ \n\
-         \ \n\
-         \#### Oracle Text \n\
-         \ \n\
-         \Keywords \n\
-         \: `o`, `oracle` \n\
-         \ \n\
-         \Operators \n\
-         \: `:` (matches)"
-    :> "search"
-    :> QueryParam' '[Description "Query string"] "q" T.Text
-    :> QueryParam' '[Description "Sorting method"] "sort_by" T.Text
-    :> QueryParam' '[Description "Search across collection or all cards"] "in_collection" T.Text
-    :> Get '[JSON] [Card]
-
-type TutorAPI =
-  GetStatus
-    :<|> SearchCards
-
-type DocsAPI =
-  "api" :> "openapi.json" :> Get '[JSON] OpenApi
-
-type ElmAPI = Raw
-
-type API = TutorAPI :<|> DocsAPI :<|> ElmAPI
-
-startApp :: FilePath -> IO ()
-startApp dbFile = withStdoutLogger $ \logger ->
-  runSettings (setPort 8080 $ setLogger logger $ defaultSettings) (app dbFile)
-
-app :: FilePath -> Application
-app dbFile = serve api $ server dbFile
-
-tutorAPI :: Proxy TutorAPI
-tutorAPI = Proxy
-
-api :: Proxy API
-api = Proxy
-
-openapi :: OpenApi
-openapi =
-  toOpenApi tutorAPI
-    & info . title .~ "Tutor API"
-    & info . version .~ packageVersion
-    & info . description ?~ "An API for searching a Magic: The Gathering card collection."
-    & info . license ?~ ("MIT" & url ?~ URL "http://mit.com")
-
-tutorServer :: FilePath -> Server TutorAPI
-tutorServer dbFile = status :<|> searchCards dbFile
-
-docsServer :: Server DocsAPI
-docsServer = return openapi
-
-elmServer :: Server ElmAPI
-elmServer = serveDirectoryFileServer "www/public"
-
-server :: FilePath -> Server API
-server dbFile = tutorServer dbFile :<|> docsServer :<|> elmServer
-
-packageVersion :: T.Text
-packageVersion = T.pack $ showVersion PT.version
-
-status :: Handler Status
-status =
-  return
-    Status
-      { apiVersion = packageVersion
-      }
-
-searchCards :: FilePath -> Maybe T.Text -> Maybe T.Text -> Maybe T.Text -> Handler [Card]
-searchCards dbFile q sortBy inCollection =
-  liftIO $
-    withConnection dbFile $ \conn ->
-      queryNamed
-        conn
-        (toQuery query)
-        (selectParameters query)
-  where
-    baseQuery =
-      selectSimple
-        [ "cards.scryfall_id",
-          "cards.name",
-          "cards.set_code",
-          "cards.collector_number",
-          "cards.rarity",
-          "cards.color_identity",
-          "cards.oracle_text",
-          "card_prices.usd",
-          "card_prices.usd_foil",
-          "card_prices.eur",
-          "card_prices.eur_foil",
-          "card_prices.tix"
-        ]
-        ["cards"]
-        <> join
-          [sql|card_prices ON (cards.scryfall_id = card_prices.scryfall_id)
-             AND card_prices.date = (SELECT value FROM vars WHERE key = :last_update_key)|]
-        <> join "rarities ON (cards.rarity = rarities.rarity)"
-        <> conditions
-        <> orderBy "rarities.rarity_ord DESC"
-        <> orderBy "length(cards.color_identity) DESC"
-        <> orderBy
-          [sql|CASE WHEN length(cards.color_identity) > 0 THEN '0'
-             ELSE cards.color_identity END ASC|]
-        <> orderBy "cards.name ASC"
-        <> parameter ":last_update_key" ("last_update" :: T.Text)
-        <> limit 10
-    query =
-      mconcat $
-        catMaybes
-          [ case sortBy of
-              Just "price" -> Just $ orderBy "CAST(COALESCE(card_prices.usd, card_prices.usd_foil) as decimal) DESC"
-              _ -> Nothing,
-            Just baseQuery,
-            case inCollection of
-              Just "no" -> Nothing
-              _ -> Just $ join "copies ON (cards.scryfall_id = copies.scryfall_id)"
-          ]
-    conditions = case parseQuery (fromMaybe "" q) of
-      Right (Search xs) -> mconcat $ [fromNamedCriteria p x | (p, x) <- zip whereParams xs]
-      Left _ -> mempty
-
-    whereParams :: [T.Text]
-    whereParams = [":where_" <> T.pack (show n) | n <- [1 ..]]
-
-    fromNamedCriteria :: T.Text -> Criteria -> Select Query
-    fromNamedCriteria param (NameContains txt) =
-      whereNamedParam "cards.name" "LIKE" param ("%" <> txt <> "%")
-    fromNamedCriteria param (ExpansionCodeIs txt) =
-      whereNamedParam "cards.set_code" "LIKE" param txt
-    fromNamedCriteria param (CardTypeContains txt) =
-      whereNamedParam "cards.type_line" "LIKE" param ("%" <> txt <> "%")
-    fromNamedCriteria param (OracleTextContains txt) =
-      whereNamedParam "cards.oracle_text" "LIKE" param ("%" <> txt <> "%")
-    fromNamedCriteria param (ColorIdentityIs colors) =
-      whereNamedParam
-        "cards.color_identity"
-        "LIKE"
-        param
-        (mconcat $ fromColors colors)
-    fromNamedCriteria param (ColorIdentityLTE colors) =
-      if L.null colorList
-        then mempty
-        else
-          mconcat
-            [ where_ $
-                mconcat
-                  [ "(",
-                    sqlJoin
-                      " OR "
-                      ( "cards.color_identity LIKE " <> Query param :
-                          [ "cards.color_identity LIKE " <> Query colorParam
-                            | colorParam <- colorParams
-                          ]
-                      ),
-                    ")"
-                  ],
-              parameter param $ mconcat colorList,
-              mconcat
-                [ parameter colorParam color
-                  | (colorParam, color) <- zip colorParams colorList
-                ]
-            ]
-      where
-        colorList = fromColors colors
-        colorParams = [param <> "_" <> color | color <- colorList]
-    fromNamedCriteria param (ColorIdentityGTE colors) =
-      whereNamedParam
-        "cards.color_identity"
-        "LIKE"
-        param
-        ("%" <> mconcat (fromColors colors) <> "%")
-    fromNamedCriteria param (RarityIs rarity) =
-      whereNamedParam "cards.rarity" "LIKE" param (rarityName rarity)
-    fromNamedCriteria param (RarityLTE rarity) =
-      whereNamedParam "rarities.rarity_ord" "<=" param (rarityValue rarity)
-    fromNamedCriteria param (RarityGTE rarity) =
-      whereNamedParam "rarities.rarity_ord" ">=" param (rarityValue rarity)
-
-    fromColors :: Colors -> [T.Text]
-    fromColors (Colors colors) = map (T.pack . show) (S.toList colors)
-
-    rarityName :: Rarity -> T.Text
-    rarityName Common = "common"
-    rarityName Uncommon = "uncommon"
-    rarityName Rare = "rare"
-    rarityName Mythic = "mythic"
-
-    rarityValue :: Rarity -> Int
-    rarityValue Common = 1
-    rarityValue Uncommon = 2
-    rarityValue Rare = 3
-    rarityValue Mythic = 5

src/Tutor.hs

@@ -0,0 +1,11 @@
+module Tutor ( startApp  )
+where
+
+import Network.Wai.Handler.Warp
+import Network.Wai.Logger
+import Servant (serve)
+import Tutor.Api (app)
+
+startApp :: FilePath -> IO ()
+startApp dbFile = withStdoutLogger $ \logger ->
+  runSettings (setPort 8080 $ setLogger logger $ defaultSettings) (app dbFile)

src/Tutor/Api.hs

@@ -0,0 +1,224 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Tutor.Api (app) where
+
+import Control.Monad.IO.Class (liftIO)
+import Control.Lens
+import Data.Aeson (FromJSON, ToJSON)
+import Data.OpenApi
+  ( HasDescription (description),
+    HasInfo (info),
+    HasLicense (license),
+    HasTitle (title),
+    HasUrl (url),
+    HasVersion (version),
+    OpenApi,
+    ToSchema,
+    URL (URL),
+  )
+import Data.Version (showVersion)
+import qualified Data.Text as T
+import Data.Typeable (Typeable)
+import GHC.Generics (Generic)
+import qualified Paths_tutor as PT
+import Servant
+import Servant.OpenApi (HasOpenApi (toOpenApi))
+import Tutor.Card
+import Tutor.Database
+
+data Status = Status
+  {apiVersion :: T.Text}
+  deriving (Generic, Typeable)
+
+instance FromJSON Status
+
+instance ToJSON Status
+
+instance ToSchema Status
+
+instance FromJSON Prices
+
+instance ToJSON Prices
+
+instance FromJSON Card
+
+instance ToJSON Card
+
+instance ToSchema Prices
+
+instance ToSchema Card
+
+type GetStatus =
+  Summary "Get API Status"
+    :> Description "Get the current running API version."
+    :> "api"
+    :> "status"
+    :> Get '[JSON] Status
+
+type SearchCards =
+  Summary "Search for cards in a collection"
+    :> Description
+         "Text in the query string will be used to filter cards having that text in their \n\
+         \name. Additionally, the keyword expressions below can be used to search for \n\
+         \cards with certain properties. \n\
+         \ \n\
+         \ \n\
+         \### Examples \n\
+         \ \n\
+         \`bolt` \n\
+         \: Find all cards with \"bolt\" in the name \n\
+         \ \n\
+         \`\"God of\"` \n\
+         \: Find all cards with \"God of\" in the name \n\
+         \ \n\
+         \`t:legendary t:creature c:jund` \n\
+         \: Find all legendary creatures with a color \n\
+         \    identity of red/blue/green \n\
+         \ \n\
+         \`color<=ubg` \n\
+         \: Find all spells that are blue, black, green, or any \n\
+         \    combination thereof. \n\
+         \ \n\
+         \`color:red set:stx rarity>=rare` \n\
+         \: Find all red cards in Strixhaven that are \n\
+         \    rare or mythic \n\
+         \ \n\
+         \`t:enchantment o:\"enters the battlefield\"` \n\
+         \: Find all enchantments with ETB \n\
+         \    effects \n\
+         \ \n\
+         \ \n\
+         \### Keywords \n\
+         \ \n\
+         \ \n\
+         \#### Colors \n\
+         \ \n\
+         \Keywords \n\
+         \: `c`, `color` \n\
+         \ \n\
+         \Operators \n\
+         \: `:` (matches), `>=` (greater than or equal to), `<=` (less than \n\
+         \    or equal to) \n\
+         \ \n\
+         \Matches cards of the chosen color or colors. \n\
+         \ \n\
+         \Single colors \n\
+         \: `w` or `white`, `u` or `blue`, `b` or `black, =g` or `green`, `r` or `red` \n\
+         \ \n\
+         \Any combination of abbreviated single colors \n\
+         \: e.g.: `rg`, `uw`, or `wubgr` \n\
+         \ \n\
+         \Ravnican guilds \n\
+         \: `boros` (white/red), `golgari` (green/black), `selesnya` \n\
+         \    (green/white), `dimir` (blue/black), `orzhov` (white/black), `izzet` \n\
+         \    (blue/red), `gruul` (red/green), `azorius` (white/blue), `rakdos` (black/red), \n\
+         \    `simic` (green/blue) \n\
+         \ \n\
+         \Alaran shards \n\
+         \: `bant` (white/green/blue), `esper` (blue/white/black), \n\
+         \    `grixis` (black/blue/red), `jund` (red/blue/green), `naya` (green/red/white) \n\
+         \ \n\
+         \Tarkirian wedges \n\
+         \: `abzan` (white/black/green), `jeskai` (white/blue/red), \n\
+         \    `sultai` (blue/black/green), `mardu` (white/black/red), `temur` \n\
+         \    (blue/red/green) \n\
+         \ \n\
+         \ \n\
+         \#### Sets \n\
+         \ \n\
+         \Keywords \n\
+         \: `s`, `set`, `e`, `expansion` \n\
+         \ \n\
+         \Operators \n\
+         \: `:` (matches) \n\
+         \ \n\
+         \ \n\
+         \#### Rarity \n\
+         \ \n\
+         \Keywords \n\
+         \: `r`, `rarity` \n\
+         \ \n\
+         \Operators \n\
+         \: `:` (matches), `>=` (greater than or equal to), `<=` (less than \n\
+         \    or equal to) \n\
+         \ \n\
+         \ \n\
+         \#### Type \n\
+         \ \n\
+         \Keywords \n\
+         \: `t`, `type` \n\
+         \ \n\
+         \Operators \n\
+         \: `:` (matches) \n\
+         \ \n\
+         \ \n\
+         \#### Oracle Text \n\
+         \ \n\
+         \Keywords \n\
+         \: `o`, `oracle` \n\
+         \ \n\
+         \Operators \n\
+         \: `:` (matches)"
+    :> "search"
+    :> QueryParam' '[Description "Query string"] "q" T.Text
+    :> QueryParam' '[Description "Sorting method"] "sort_by" T.Text
+    :> QueryParam' '[Description "Search across collection or all cards"] "in_collection" T.Text
+    :> Get '[JSON] [Card]
+
+type TutorAPI =
+  GetStatus
+    :<|> SearchCards
+
+type DocsAPI =
+  "api" :> "openapi.json" :> Get '[JSON] OpenApi
+
+type ElmAPI = Raw
+
+type API = TutorAPI :<|> DocsAPI :<|> ElmAPI
+
+tutorAPI :: Proxy TutorAPI
+tutorAPI = Proxy
+
+api :: Proxy API
+api = Proxy
+
+openapi :: OpenApi
+openapi =
+  toOpenApi tutorAPI
+    & info . title .~ "Tutor API"
+    & info . version .~ packageVersion
+    & info . description ?~ "An API for searching a Magic: The Gathering card collection."
+    & info . license ?~ ("MIT" & url ?~ URL "http://mit.com")
+
+tutorServer :: FilePath -> Server TutorAPI
+tutorServer dbFile = status :<|> searchCards dbFile
+  where
+    searchCards :: FilePath -> Maybe T.Text -> Maybe T.Text -> Maybe T.Text -> Handler [Card]
+    searchCards dbFile q sortBy inCollection =
+      liftIO $ Tutor.Database.searchCards dbFile q sortBy inCollection
+
+docsServer :: Server DocsAPI
+docsServer = return openapi
+
+elmServer :: Server ElmAPI
+elmServer = serveDirectoryFileServer "www/public"
+
+server :: FilePath -> Server API
+server dbFile = tutorServer dbFile :<|> docsServer :<|> elmServer
+
+packageVersion :: T.Text
+packageVersion = T.pack $ showVersion PT.version
+
+status :: Handler Status
+status =
+  return
+    Status
+      { apiVersion = packageVersion
+      }
+
+app :: FilePath -> Application
+app dbFile = serve api $ server dbFile

src/Tutor/Card.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Tutor.Card where
+
+import qualified  Data.Text as T
+import GHC.Generics (Generic)
+import Data.Typeable (Typeable)
+import qualified Data.UUID as UUID
+data Prices = Prices
+  { usd :: Maybe T.Text,
+    usd_foil :: Maybe T.Text,
+    eur :: Maybe T.Text,
+    eur_foil :: Maybe T.Text,
+    tix :: Maybe T.Text
+  }
+  deriving (Eq, Show, Generic, Typeable)
+
+
+data Card = Card
+  { scryfall_id :: UUID.UUID,
+    name :: T.Text,
+    set_code :: T.Text,
+    collector_number :: T.Text,
+    rarity :: T.Text,
+    color_identity :: T.Text,
+    oracle_text :: Maybe T.Text,
+    prices :: Prices
+  }
+  deriving (Eq, Show, Generic, Typeable)
+

src/Tutor/Database.hs

@@ -0,0 +1,181 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Tutor.Database (searchCards) where
+
+import qualified Data.List as List
+import Data.Maybe
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import qualified Data.UUID as UUID
+import Database.SQLite.Simple
+import Database.SQLite.Simple.FromField
+import Database.SQLite.Simple.Internal
+import Database.SQLite.Simple.Ok
+import Database.SQLite.Simple.QQ
+import Tutor.Card
+import Tutor.Search
+import Tutor.SearchParser
+import Tutor.Select
+
+instance FromField UUID.UUID where
+  fromField (Field (SQLText txt) _) = Ok $ fromMaybe UUID.nil $ UUID.fromText txt
+  fromField f = returnError ConversionFailed f "need a text"
+
+
+instance FromRow Card where
+  fromRow = do
+    scryfall_id <- field
+    name <- field
+    set_code <- field
+    collector_number <- field
+    rarity <- field
+    color_identity <- field
+    oracle_text <- field
+    price_usd <- field
+    price_usd_foil <- field
+    price_eur <- field
+    price_eur_foil <- field
+    price_tix <- field
+    return $
+      Card
+        { scryfall_id = scryfall_id,
+          name = name,
+          set_code = set_code,
+          collector_number = collector_number,
+          rarity = rarity,
+          color_identity = color_identity,
+          oracle_text = oracle_text,
+          prices =
+            Prices
+              { usd = price_usd,
+                usd_foil = price_usd_foil,
+                eur = price_eur,
+                eur_foil = price_eur_foil,
+                tix = price_tix
+              }
+        }
+
+searchCards :: FilePath -> Maybe T.Text -> Maybe T.Text -> Maybe T.Text -> IO [Card]
+searchCards dbFile q sortBy inCollection =
+  withConnection dbFile $ \conn ->
+    queryNamed
+      conn
+      (toQuery query)
+      (selectParameters query)
+  where
+    baseQuery =
+      selectSimple
+        [ "cards.scryfall_id",
+          "cards.name",
+          "cards.set_code",
+          "cards.collector_number",
+          "cards.rarity",
+          "cards.color_identity",
+          "cards.oracle_text",
+          "card_prices.usd",
+          "card_prices.usd_foil",
+          "card_prices.eur",
+          "card_prices.eur_foil",
+          "card_prices.tix"
+        ]
+        ["cards"]
+        <> join
+          [sql|card_prices ON (cards.scryfall_id = card_prices.scryfall_id)
+             AND card_prices.date = (SELECT value FROM vars WHERE key = :last_update_key)|]
+        <> join "rarities ON (cards.rarity = rarities.rarity)"
+        <> conditions
+        <> orderBy "rarities.rarity_ord DESC"
+        <> orderBy "length(cards.color_identity) DESC"
+        <> orderBy
+          [sql|CASE WHEN length(cards.color_identity) > 0 THEN '0'
+             ELSE cards.color_identity END ASC|]
+        <> orderBy "cards.name ASC"
+        <> parameter ":last_update_key" ("last_update" :: T.Text)
+        <> limit 10
+    query =
+      mconcat $
+        catMaybes
+          [ case sortBy of
+              Just "price" -> Just $ orderBy "CAST(COALESCE(card_prices.usd, card_prices.usd_foil) as decimal) DESC"
+              _ -> Nothing,
+            Just baseQuery,
+            case inCollection of
+              Just "no" -> Nothing
+              _ -> Just $ join "copies ON (cards.scryfall_id = copies.scryfall_id)"
+          ]
+    conditions = case parseQuery (fromMaybe "" q) of
+      Right (Search xs) -> mconcat $ [fromNamedCriteria p x | (p, x) <- zip whereParams xs]
+      Left _ -> mempty
+
+    whereParams :: [T.Text]
+    whereParams = [":where_" <> T.pack (show n) | n <- [1 ..]]
+
+    fromNamedCriteria :: T.Text -> Criteria -> Select Query
+    fromNamedCriteria param (NameContains txt) =
+      whereNamedParam "cards.name" "LIKE" param ("%" <> txt <> "%")
+    fromNamedCriteria param (ExpansionCodeIs txt) =
+      whereNamedParam "cards.set_code" "LIKE" param txt
+    fromNamedCriteria param (CardTypeContains txt) =
+      whereNamedParam "cards.type_line" "LIKE" param ("%" <> txt <> "%")
+    fromNamedCriteria param (OracleTextContains txt) =
+      whereNamedParam "cards.oracle_text" "LIKE" param ("%" <> txt <> "%")
+    fromNamedCriteria param (ColorIdentityIs colors) =
+      whereNamedParam
+        "cards.color_identity"
+        "LIKE"
+        param
+        (mconcat $ fromColors colors)
+    fromNamedCriteria param (ColorIdentityLTE colors) =
+      if List.null colorList
+        then mempty
+        else
+          mconcat
+            [ where_ $
+                mconcat
+                  [ "(",
+                    sqlJoin
+                      " OR "
+                      ( "cards.color_identity LIKE " <> Query param :
+                          [ "cards.color_identity LIKE " <> Query colorParam
+                            | colorParam <- colorParams
+                          ]
+                      ),
+                    ")"
+                  ],
+              parameter param $ mconcat colorList,
+              mconcat
+                [ parameter colorParam color
+                  | (colorParam, color) <- zip colorParams colorList
+                ]
+            ]
+      where
+        colorList = fromColors colors
+        colorParams = [param <> "_" <> color | color <- colorList]
+    fromNamedCriteria param (ColorIdentityGTE colors) =
+      whereNamedParam
+        "cards.color_identity"
+        "LIKE"
+        param
+        ("%" <> mconcat (fromColors colors) <> "%")
+    fromNamedCriteria param (RarityIs rarity) =
+      whereNamedParam "cards.rarity" "LIKE" param (rarityName rarity)
+    fromNamedCriteria param (RarityLTE rarity) =
+      whereNamedParam "rarities.rarity_ord" "<=" param (rarityValue rarity)
+    fromNamedCriteria param (RarityGTE rarity) =
+      whereNamedParam "rarities.rarity_ord" ">=" param (rarityValue rarity)
+
+    fromColors :: Colors -> [T.Text]
+    fromColors (Colors colors) = map (T.pack . show) (Set.toList colors)
+
+    rarityName :: Rarity -> T.Text
+    rarityName Common = "common"
+    rarityName Uncommon = "uncommon"
+    rarityName Rare = "rare"
+    rarityName Mythic = "mythic"
+
+    rarityValue :: Rarity -> Int
+    rarityValue Common = 1
+    rarityValue Uncommon = 2
+    rarityValue Rare = 3
+    rarityValue Mythic = 5

src/Tutor/Search.hs

@@ -1,4 +1,4 @@
-module Search where
+module Tutor.Search where
 
 import qualified Data.Char as C
 import qualified Data.Set as Set

src/Tutor/SearchParser.hs

@@ -1,4 +1,4 @@
-module SearchParser
+module Tutor.SearchParser
   ( parseQuery,
   )
 where
@@ -6,9 +6,9 @@ where
 import qualified Control.Monad as Text.Parsec
 import qualified Data.Set as Set
 import qualified Data.Text as T
-import Search
 import Text.Parsec
 import Text.Parsec.Text (Parser)
+import Tutor.Search
 
 literal :: Parser T.Text
 literal = bareLiteral <|> quotedLiteral

src/Tutor/Select.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Select
+module Tutor.Select
   ( Select,
     toQuery,
     selectSimple,
@@ -27,7 +27,7 @@ import Data.String
 import Data.Text
 import Database.SQLite.Simple
 import Database.SQLite.Simple.Ok
-import Search
+import Tutor.Search
 
 data Select a = Select
   { selectColumns :: [a],

test/AppSpec.hs

@@ -3,7 +3,7 @@
 
 module AppSpec (spec) where
 
-import Lib (app)
+import Tutor (app)
 import Test.Hspec
 import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON

test/SearchParserSpec.hs

@@ -3,8 +3,8 @@
 module SearchParserSpec (spec) where
 
 import Data.Text
-import Search
-import SearchParser (parseQuery)
+import Tutor.Search
+import Tutor.SearchParser (parseQuery)
 import Test.Hspec
 import qualified Text.Parsec.Error
 main :: IO ()

tutor.cabal

@@ -1,108 +0,0 @@
-cabal-version: 1.12
-
--- This file has been generated from package.yaml by hpack version 0.34.4.
---
--- see: https://github.com/sol/hpack
-
-name:           tutor
-version:        0.1.0.0
-description:    Please see the README on GitHub at <https://github.com/githubuser/tutor#readme>
-homepage:       https://github.com/githubuser/tutor#readme
-bug-reports:    https://github.com/githubuser/tutor/issues
-author:         Author name here
-maintainer:     example@example.com
-copyright:      2022 Author name here
-license:        BSD3
-build-type:     Simple
-extra-source-files:
-    README.org
-
-source-repository head
-  type: git
-  location: https://github.com/githubuser/tutor
-
-library
-  exposed-modules:
-      Lib
-      Search
-      SearchParser
-      Select
-  other-modules:
-      Paths_tutor
-  hs-source-dirs:
-      src
-  build-depends:
-      aeson
-    , base >=4.7 && <5
-    , containers
-    , lens
-    , openapi3
-    , parsec
-    , parsec-extra
-    , servant-openapi3
-    , servant-server
-    , sqlite-simple
-    , text
-    , uuid
-    , wai
-    , wai-logger
-    , warp
-  default-language: Haskell2010
-
-executable tutor-exe
-  main-is: Main.hs
-  other-modules:
-      Paths_tutor
-  hs-source-dirs:
-      app
-  ghc-options: -threaded -rtsopts -with-rtsopts=-N
-  build-depends:
-      aeson
-    , base
-    , containers
-    , lens
-    , openapi3
-    , parsec
-    , parsec-extra
-    , servant-openapi3
-    , servant-server
-    , sqlite-simple
-    , text
-    , tutor
-    , uuid
-    , wai
-    , wai-logger
-    , warp
-  default-language: Haskell2010
-
-test-suite tutor-test
-  type: exitcode-stdio-1.0
-  main-is: Spec.hs
-  other-modules:
-      AppSpec
-      SearchParserSpec
-      Paths_tutor
-  hs-source-dirs:
-      test
-  ghc-options: -threaded -rtsopts -with-rtsopts=-N
-  build-depends:
-      aeson
-    , base
-    , containers
-    , hspec
-    , hspec-wai
-    , hspec-wai-json
-    , lens
-    , openapi3
-    , parsec
-    , parsec-extra
-    , servant-openapi3
-    , servant-server
-    , sqlite-simple
-    , text
-    , tutor
-    , uuid
-    , wai
-    , wai-logger
-    , warp
-  default-language: Haskell2010