SQLite.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UnicodeSyntax #-}

module Database.SQLite (
  DatabaseSQLite (..),
  defaultDatabase,
  mkHandle,
)
where

import Data.Aeson (decode, encode)
import Database.Beam
import Database.Beam.Backend.SQL (BeamSqlBackend, HasSqlValueSyntax (..))
import Database.Beam.Backend.SQL.BeamExtensions

-- import           Database.Beam.Migrate
import Database.Beam.Sqlite (SqliteM, runBeamSqlite)
import Database.Handle hiding (deleteFeed, insertFeed, insertItem, purge)
import Database.SQLite.Simple
import Imm.Feed
import Imm.Pretty
import System.Directory

-- * Schema

data FeedLocationT f = FeedLocationT
  { _locationID ∷ Columnar f Int32
  , _locationValue ∷ Columnar f FeedLocation
  }
  deriving (Generic, Beamable)

instance Table FeedLocationT where
  data PrimaryKey FeedLocationT f = FeedLocationKey (Columnar f Int32)
    deriving (Generic, Beamable)
  primaryKey = FeedLocationKey . _locationID

data FeedT f = Feed
  { _feedKeyT ∷ PrimaryKey FeedLocationT f
  , _feedDefinitionT ∷ Columnar f FeedDefinition
  , _feedStatusT ∷ Columnar f FeedStatus
  }
  deriving (Generic, Beamable)

instance Table FeedT where
  data PrimaryKey FeedT f = FeedKey (PrimaryKey FeedLocationT f)
    deriving (Generic, Beamable)
  primaryKey = FeedKey . _feedKeyT

data FeedItemT f = FeedItemT
  { _itemKeyT ∷ Columnar f Int32
  , _itemFeedKeyT ∷ PrimaryKey FeedLocationT f
  , _itemDefinitionT ∷ Columnar f FeedItem
  , _itemStatusT ∷ Columnar f FeedItemStatus
  }
  deriving (Generic, Beamable)

instance Table FeedItemT where
  data PrimaryKey FeedItemT f = FeedItemKey (Columnar f Int32)
    deriving (Generic, Beamable)
  primaryKey = FeedItemKey . _itemKeyT

data FeedDatabase f = FeedDatabase
  { _feedLocations ∷ f (TableEntity FeedLocationT)
  , _feeds ∷ f (TableEntity FeedT)
  , _feedItems ∷ f (TableEntity FeedItemT)
  }
  deriving (Generic, Database be)

feedDatabase ∷ DatabaseSettings be FeedDatabase
feedDatabase =
  defaultDbSettings
    `withDbModification` dbModification
      { _feedItems =
          modifyTableFields
            tableModification
              { _itemKeyT = fieldNamed "key"
              , _itemFeedKeyT = FeedLocationKey $ fieldNamed "feed_key"
              , _itemDefinitionT = fieldNamed "definition"
              , _itemStatusT = fieldNamed "status"
              }
      , _feeds =
          modifyTableFields
            tableModification
              { _feedKeyT = FeedLocationKey $ fieldNamed "key"
              , _feedDefinitionT = fieldNamed "definition"
              , _feedStatusT = fieldNamed "status"
              }
      , _feedLocations =
          modifyTableFields
            tableModification
              { _locationID = fieldNamed "key"
              , _locationValue = fieldNamed "value"
              }
      }

feedLocationsTable ∷ DatabaseEntity be FeedDatabase (TableEntity FeedLocationT)
feedLocationsTable = _feedLocations feedDatabase

feedsTable ∷ DatabaseEntity be FeedDatabase (TableEntity FeedT)
feedsTable = _feeds feedDatabase

feedItemsTable ∷ DatabaseEntity be FeedDatabase (TableEntity FeedItemT)
feedItemsTable = _feedItems feedDatabase

-- * Queries

fetchAllFeeds ∷ SqliteM [FeedRecord Inserted]
fetchAllFeeds = fmap (map asFeedRecord) $ runSelectReturningList $ select $ do
  feed ← feedsTable & all_
  location ← feedLocationsTable & all_

  guard_ $ _feedKeyT feed `references_` location

  pure (location, feed)

asFeedRecord ∷ f ~ Identity ⇒ (FeedLocationT f, FeedT f) → FeedRecord Inserted
asFeedRecord (locationT, feed) =
  FeedRecord
    (fromIntegral $ _locationID locationT)
    (_locationValue locationT)
    (_feedDefinitionT feed)
    (_feedStatusT feed)

fetchFeed ∷ UID → SqliteM (FeedRecord Inserted)
fetchFeed uid =
  select (queryFeed uid)
    & runSelectReturningOne
    >>= maybe (fail $ "Feed not found: " <> show uid) return
      <&> asFeedRecord

queryFeed ∷ UID → _
queryFeed uid = do
  feed ← feedsTable & all_
  location ← feedLocationsTable & all_

  guard_ $ _feedKeyT feed `references_` location
  guard_ $ _locationID location ==. val_ (fromIntegral uid)

  pure (location, feed)

fetchItem ∷ UID → SqliteM (FeedItemRecord Inserted)
fetchItem uid =
  feedItemsTable
    & all_
    & filter_ (\i → primaryKey i ==. val_ (FeedItemKey $ fromIntegral uid))
    & select
    & runSelectReturningOne
    >>= maybe (fail $ "Item not found: " <> show uid) return
      <&> asFeedItemRecord

fetchAllItems ∷ SqliteM [FeedItemRecord Inserted]
fetchAllItems =
  select (feedItemsTable & all_)
    & runSelectReturningList
    <&> map asFeedItemRecord

fetchItems ∷ UID → SqliteM [FeedItemRecord Inserted]
fetchItems uid = select (queryItems uid) & runSelectReturningList <&> map asFeedItemRecord

queryItems ∷ UID → _
queryItems uid = do
  item ← feedItemsTable & all_
  guard_ $ _itemFeedKeyT item ==. val_ (FeedLocationKey $ fromIntegral uid)
  pure item

asFeedItemRecord ∷ FeedItemT Identity → FeedItemRecord Inserted
asFeedItemRecord item =
  FeedItemRecord
    (fromIntegral $ _itemKeyT item)
    (fromIntegral feedKey)
    (_itemDefinitionT item)
    (_itemStatusT item)
 where
  FeedLocationKey feedKey = _itemFeedKeyT item

deleteFeed ∷ UID → SqliteM ()
deleteFeed uid = do
  -- runDelete $ delete feedItemsTable $ \item -> _itemFeedKeyT item ==. val_ (FeedLocationKey $ fromIntegral uid)
  -- runDelete $ delete feedsTable $ \feed -> _feedKeyT feed ==. val_ (FeedLocationKey $ fromIntegral uid)
  runDelete $ delete feedLocationsTable $ \location → _locationID location ==. val_ (fromIntegral uid)

insertFeed ∷ FeedRecord NotInserted → SqliteM (FeedRecord Inserted)
insertFeed record = do
  location ← insertFeedLocation $ _feedLocation record
  let value = Feed (primaryKey location) (_feedDefinition record) (_feedStatus record)
  feed ←
    insertValues [value]
      & insert feedsTable
      & runInsertReturningList
      >>= headFail (displayException $ FeedsNotInserted [record])
  return $ asFeedRecord (location, feed)

insertFeedLocation ∷ FeedLocation → SqliteM (FeedLocationT Identity)
insertFeedLocation location =
  insertExpressions [FeedLocationT default_ (val_ location)]
    & insert feedLocationsTable
    & runInsertReturningList
    >>= headFail ("Unable to insert feed location " <> show location)

insertItem ∷ FeedItemRecord NotInserted → SqliteM (FeedItemRecord Inserted)
insertItem record = do
  inserted ←
    insertExpressions [FeedItemT default_ (val_ $ FeedLocationKey $ fromIntegral $ _itemFeedKey record) (val_ $ _itemDefinition record) (val_ $ _itemStatus record)]
      & insert feedItemsTable
      & runInsertReturningList
      >>= headFail (displayException $ ItemsNotInserted [record])
  return $ FeedItemRecord (fromIntegral $ _itemKeyT inserted) (_itemFeedKey record) (_itemDefinition record) (_itemStatus record)

purge ∷ SqliteM ()
purge = runDelete $ delete feedLocationsTable $ \_ → val_ True

updateItemStatus ∷ FeedItemRecord Inserted → SqliteM ()
updateItemStatus record =
  runUpdate $
    update
      feedItemsTable
      (\item → _itemStatusT item <-. val_ (_itemStatus record))
      (\item → primaryKey item ==. val_ (FeedItemKey $ fromIntegral $ _itemKey record))

updateFeedDefinition ∷ FeedRecord Inserted → SqliteM ()
updateFeedDefinition record =
  runUpdate $
    update
      feedsTable
      (\feed → _feedDefinitionT feed <-. val_ (_feedDefinition record))
      (\feed → primaryKey feed ==. val_ (FeedKey $ FeedLocationKey $ fromIntegral $ _feedKey record))

updateFeedStatus ∷ FeedRecord Inserted → SqliteM ()
updateFeedStatus record =
  runUpdate $
    update
      feedsTable
      (\feed → _feedStatusT feed <-. val_ (_feedStatus record))
      (\feed → primaryKey feed ==. val_ (FeedKey $ FeedLocationKey $ fromIntegral $ _feedKey record))

-- * Handle

newtype DatabaseSQLite = DatabaseSQLite
  { _sqliteFile ∷ FilePath
  }

instance Pretty DatabaseSQLite where
  pretty db = "SQLite database: " <+> pretty (_sqliteFile db)

-- | Default database is stored in @$XDG_CONFIG_HOME\/imm\/database.sqlite@
defaultDatabase ∷ IO DatabaseSQLite
defaultDatabase = DatabaseSQLite <$> getXdgDirectory XdgConfig "imm/database.sqlite"

createTables ∷ Connection → IO ()
createTables conn = do
  execute_ conn "CREATE TABLE IF NOT EXISTS locations (key INTEGER NOT NULL PRIMARY KEY, value BLOB NOT NULL UNIQUE);"
  execute_
    conn
    "CREATE TABLE IF NOT EXISTS feeds ( \
    \ key INTEGER NOT NULL PRIMARY KEY, definition BLOB NOT NULL, status BLOB NOT NULL, \
    \ CONSTRAINT fk_feeds FOREIGN KEY (key) REFERENCES locations(key) ON DELETE CASCADE \
    \ );"
  execute_
    conn
    "CREATE TABLE IF NOT EXISTS items ( \
    \ key INTEGER NOT NULL PRIMARY KEY, feed_key INTEGER NOT NULL, definition BLOB NOT NULL, status BLOB NOT NULL, \
    \ CONSTRAINT fk_feeds FOREIGN KEY (feed_key) REFERENCES locations(key) ON DELETE CASCADE \
    \ );"

mkHandle ∷ DatabaseSQLite → IO (Handle IO)
mkHandle database = do
  conn ← open $ _sqliteFile database
  createTables conn
  execute_ conn "PRAGMA foreign_keys = ON;"

  return $
    Handle
      { _describeDatabase = return $ pretty database
      , _fetchAllFeeds = runBeamSqlite conn fetchAllFeeds
      , _fetchFeed = runBeamSqlite conn . fetchFeed
      , _fetchItems = runBeamSqlite conn . fetchItems
      , _fetchAllItems = runBeamSqlite conn fetchAllItems
      , _fetchItem = runBeamSqlite conn . fetchItem
      , _updateFeedDefinition = runBeamSqlite conn . updateFeedDefinition
      , _updateFeedStatus = runBeamSqlite conn . updateFeedStatus
      , _updateItemStatus = runBeamSqlite conn . updateItemStatus
      , _insertFeed = runBeamSqlite conn . insertFeed
      , _insertItem = runBeamSqlite conn . insertItem
      , _deleteFeed = runBeamSqlite conn . deleteFeed
      , _purge = runBeamSqlite conn purge
      , _commit = return ()
      }

instance (BeamSqlBackend be, FromBackendRow be LByteString) ⇒ FromBackendRow be FeedLocation where
  fromBackendRow = fromBackendRow <&> decode >>= maybe empty pure

instance HasSqlValueSyntax be ByteString ⇒ HasSqlValueSyntax be FeedLocation where
  sqlValueSyntax = sqlValueSyntax . toStrict . encode

instance (BeamSqlBackend be, FromBackendRow be LByteString) ⇒ FromBackendRow be FeedItem where
  fromBackendRow = fromBackendRow <&> decode >>= maybe empty pure

instance HasSqlValueSyntax be ByteString ⇒ HasSqlValueSyntax be FeedItem where
  sqlValueSyntax = sqlValueSyntax . toStrict . encode

instance (BeamSqlBackend be, FromBackendRow be LByteString) ⇒ FromBackendRow be FeedDefinition where
  fromBackendRow = fromBackendRow <&> decode >>= maybe empty pure

instance HasSqlValueSyntax be ByteString ⇒ HasSqlValueSyntax be FeedDefinition where
  sqlValueSyntax = sqlValueSyntax . toStrict . encode

instance (BeamSqlBackend be, FromBackendRow be LByteString) ⇒ FromBackendRow be FeedStatus where
  fromBackendRow = fromBackendRow <&> decode >>= maybe empty pure

instance HasSqlValueSyntax be ByteString ⇒ HasSqlValueSyntax be FeedStatus where
  sqlValueSyntax = sqlValueSyntax . toStrict . encode

instance (BeamSqlBackend be, FromBackendRow be LByteString) ⇒ FromBackendRow be FeedItemStatus where
  fromBackendRow = fromBackendRow <&> decode >>= maybe empty pure

instance HasSqlValueSyntax be ByteString ⇒ HasSqlValueSyntax be FeedItemStatus where
  sqlValueSyntax = sqlValueSyntax . toStrict . encode