----------------------------------------------------------------------------------------------------

-- | Interface to use a MySQL table with a very specific format, where each row
--   consists of a row identifier - used for lookups - and a JSON-encoded value.
--
-- +----------------------------+--------------------+
-- |             id             |        data        |
-- +============================+====================+
-- | Row identifier (type 'Id') | JSON-encoded value |
-- +----------------------------+--------------------+
--
module Database.MySQL.JSONTable
  ( -- * JSON tables
    -- ** Types
    Id
  , Row (..)
  , JSONTable (..)
    -- * Connections
  , SQL.ConnectInfo (..)
  , SQL.defaultConnectInfo
  , SQL.Connection
  , withSQL
    -- ** Table operations
  , createTable
  , deleteTable
    -- ** Row operations
  , insert
  , lookup
  , adjust
  , delete
  , replace
    -- ** Streaming
  , sourceRows
    -- * Id tables
    -- ** Types
  , IdTable (..)
    -- ** Table operations
  , createIdTable
  , deleteIdTable
    -- ** Row operations
  , insertId
  , lookupId
  , adjustId
  , alterId
  , deleteId
  , replaceId
  , moveId
    -- ** Streaming
  , sourceIds
    ) where

import Prelude hiding (lookup)
import Data.Word
import Data.String (fromString)
import Data.Char (toUpper)
import Text.Read (readEither)
import Data.Maybe (listToMaybe)
import Data.Typeable (Typeable)
import Data.Proxy
import Control.Applicative (liftA2)
import Control.Monad (forM_, when, unless)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Catch (MonadMask, bracket)
#if MIN_VERSION_bytestring(0,11,0)
import Data.ByteString qualified as ByteString
#else
import Data.ByteString.Lazy qualified as LazyByteString
#endif
import Data.ByteString.Char8 qualified as CByteString
import Database.MySQL.Simple qualified as SQL
import Database.MySQL.Simple.QueryResults qualified as SQL
import Database.MySQL.Base qualified as SQLBase
import Data.Aeson (FromJSON, ToJSON, FromJSONKey, ToJSONKey)
import Data.Aeson qualified as JSON
import Data.Conduit (ConduitT)
import Conduit (ResourceT)
import Data.Conduit qualified as Conduit
import Web.HttpApiData (FromHttpApiData, ToHttpApiData)
import Data.Hashable (Hashable)

-- | Open a connection to a MySQL server and apply a function to it.
--   The connection is closed both when the function completes or throws an exception.
withSQL :: (MonadMask m, MonadIO m) => SQL.ConnectInfo -> (SQL.Connection -> m a) -> m a
withSQL :: forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
ConnectInfo -> (Connection -> m a) -> m a
withSQL ConnectInfo
sql = m Connection -> (Connection -> m ()) -> (Connection -> m a) -> m a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (IO Connection -> m Connection
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Connection -> m Connection) -> IO Connection -> m Connection
forall a b. (a -> b) -> a -> b
$ ConnectInfo -> IO Connection
SQL.connect ConnectInfo
sql) (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Connection -> IO ()) -> Connection -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> IO ()
SQL.close)

-- | Row identifier used for table lookups.
--   The type parameter indicates the type of data
--   stored in the table.
newtype Id a = Id { forall a. Id a -> Word64
fromId :: Word64 }
  deriving ( Id a -> Id a -> Bool
(Id a -> Id a -> Bool) -> (Id a -> Id a -> Bool) -> Eq (Id a)
forall a. Id a -> Id a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Id a -> Id a -> Bool
== :: Id a -> Id a -> Bool
$c/= :: forall a. Id a -> Id a -> Bool
/= :: Id a -> Id a -> Bool
Eq, Eq (Id a)
Eq (Id a) =>
(Id a -> Id a -> Ordering)
-> (Id a -> Id a -> Bool)
-> (Id a -> Id a -> Bool)
-> (Id a -> Id a -> Bool)
-> (Id a -> Id a -> Bool)
-> (Id a -> Id a -> Id a)
-> (Id a -> Id a -> Id a)
-> Ord (Id a)
Id a -> Id a -> Bool
Id a -> Id a -> Ordering
Id a -> Id a -> Id a
forall a. Eq (Id a)
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Id a -> Id a -> Bool
forall a. Id a -> Id a -> Ordering
forall a. Id a -> Id a -> Id a
$ccompare :: forall a. Id a -> Id a -> Ordering
compare :: Id a -> Id a -> Ordering
$c< :: forall a. Id a -> Id a -> Bool
< :: Id a -> Id a -> Bool
$c<= :: forall a. Id a -> Id a -> Bool
<= :: Id a -> Id a -> Bool
$c> :: forall a. Id a -> Id a -> Bool
> :: Id a -> Id a -> Bool
$c>= :: forall a. Id a -> Id a -> Bool
>= :: Id a -> Id a -> Bool
$cmax :: forall a. Id a -> Id a -> Id a
max :: Id a -> Id a -> Id a
$cmin :: forall a. Id a -> Id a -> Id a
min :: Id a -> Id a -> Id a
Ord, Int -> Id a -> ShowS
[Id a] -> ShowS
Id a -> [Char]
(Int -> Id a -> ShowS)
-> (Id a -> [Char]) -> ([Id a] -> ShowS) -> Show (Id a)
forall a. Int -> Id a -> ShowS
forall a. [Id a] -> ShowS
forall a. Id a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Int -> Id a -> ShowS
showsPrec :: Int -> Id a -> ShowS
$cshow :: forall a. Id a -> [Char]
show :: Id a -> [Char]
$cshowList :: forall a. [Id a] -> ShowS
showList :: [Id a] -> ShowS
Show, [Id a] -> Value
[Id a] -> Encoding
Id a -> Bool
Id a -> Value
Id a -> Encoding
(Id a -> Value)
-> (Id a -> Encoding)
-> ([Id a] -> Value)
-> ([Id a] -> Encoding)
-> (Id a -> Bool)
-> ToJSON (Id a)
forall a. [Id a] -> Value
forall a. [Id a] -> Encoding
forall a. Id a -> Bool
forall a. Id a -> Value
forall a. Id a -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: forall a. Id a -> Value
toJSON :: Id a -> Value
$ctoEncoding :: forall a. Id a -> Encoding
toEncoding :: Id a -> Encoding
$ctoJSONList :: forall a. [Id a] -> Value
toJSONList :: [Id a] -> Value
$ctoEncodingList :: forall a. [Id a] -> Encoding
toEncodingList :: [Id a] -> Encoding
$comitField :: forall a. Id a -> Bool
omitField :: Id a -> Bool
ToJSON, Maybe (Id a)
Value -> Parser [Id a]
Value -> Parser (Id a)
(Value -> Parser (Id a))
-> (Value -> Parser [Id a]) -> Maybe (Id a) -> FromJSON (Id a)
forall a. Maybe (Id a)
forall a. Value -> Parser [Id a]
forall a. Value -> Parser (Id a)
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: forall a. Value -> Parser (Id a)
parseJSON :: Value -> Parser (Id a)
$cparseJSONList :: forall a. Value -> Parser [Id a]
parseJSONList :: Value -> Parser [Id a]
$comittedField :: forall a. Maybe (Id a)
omittedField :: Maybe (Id a)
FromJSON, FromJSONKeyFunction [Id a]
FromJSONKeyFunction (Id a)
FromJSONKeyFunction (Id a)
-> FromJSONKeyFunction [Id a] -> FromJSONKey (Id a)
forall a. FromJSONKeyFunction [Id a]
forall a. FromJSONKeyFunction (Id a)
forall a.
FromJSONKeyFunction a -> FromJSONKeyFunction [a] -> FromJSONKey a
$cfromJSONKey :: forall a. FromJSONKeyFunction (Id a)
fromJSONKey :: FromJSONKeyFunction (Id a)
$cfromJSONKeyList :: forall a. FromJSONKeyFunction [Id a]
fromJSONKeyList :: FromJSONKeyFunction [Id a]
FromJSONKey, ToJSONKeyFunction [Id a]
ToJSONKeyFunction (Id a)
ToJSONKeyFunction (Id a)
-> ToJSONKeyFunction [Id a] -> ToJSONKey (Id a)
forall a. ToJSONKeyFunction [Id a]
forall a. ToJSONKeyFunction (Id a)
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
$ctoJSONKey :: forall a. ToJSONKeyFunction (Id a)
toJSONKey :: ToJSONKeyFunction (Id a)
$ctoJSONKeyList :: forall a. ToJSONKeyFunction [Id a]
toJSONKeyList :: ToJSONKeyFunction [Id a]
ToJSONKey
           , Text -> Either Text (Id a)
ByteString -> Either Text (Id a)
(Text -> Either Text (Id a))
-> (ByteString -> Either Text (Id a))
-> (Text -> Either Text (Id a))
-> FromHttpApiData (Id a)
forall a. Text -> Either Text (Id a)
forall a. ByteString -> Either Text (Id a)
forall a.
(Text -> Either Text a)
-> (ByteString -> Either Text a)
-> (Text -> Either Text a)
-> FromHttpApiData a
$cparseUrlPiece :: forall a. Text -> Either Text (Id a)
parseUrlPiece :: Text -> Either Text (Id a)
$cparseHeader :: forall a. ByteString -> Either Text (Id a)
parseHeader :: ByteString -> Either Text (Id a)
$cparseQueryParam :: forall a. Text -> Either Text (Id a)
parseQueryParam :: Text -> Either Text (Id a)
FromHttpApiData, Id a -> Text
Id a -> ByteString
Id a -> Builder
(Id a -> Text)
-> (Id a -> Builder)
-> (Id a -> ByteString)
-> (Id a -> Text)
-> (Id a -> Builder)
-> ToHttpApiData (Id a)
forall a. Id a -> Text
forall a. Id a -> ByteString
forall a. Id a -> Builder
forall a.
(a -> Text)
-> (a -> Builder)
-> (a -> ByteString)
-> (a -> Text)
-> (a -> Builder)
-> ToHttpApiData a
$ctoUrlPiece :: forall a. Id a -> Text
toUrlPiece :: Id a -> Text
$ctoEncodedUrlPiece :: forall a. Id a -> Builder
toEncodedUrlPiece :: Id a -> Builder
$ctoHeader :: forall a. Id a -> ByteString
toHeader :: Id a -> ByteString
$ctoQueryParam :: forall a. Id a -> Text
toQueryParam :: Id a -> Text
$ctoEncodedQueryParam :: forall a. Id a -> Builder
toEncodedQueryParam :: Id a -> Builder
ToHttpApiData, Eq (Id a)
Eq (Id a) =>
(Int -> Id a -> Int) -> (Id a -> Int) -> Hashable (Id a)
Int -> Id a -> Int
Id a -> Int
forall a. Eq (Id a)
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall a. Int -> Id a -> Int
forall a. Id a -> Int
$chashWithSalt :: forall a. Int -> Id a -> Int
hashWithSalt :: Int -> Id a -> Int
$chash :: forall a. Id a -> Int
hash :: Id a -> Int
Hashable )

instance SQL.FromField (Id a) where
  fromField :: ([Type], ByteString -> Either [Char] (Id a))
fromField = ([Type
SQLBase.LongLong], (Word64 -> Id a) -> Either [Char] Word64 -> Either [Char] (Id a)
forall a b. (a -> b) -> Either [Char] a -> Either [Char] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word64 -> Id a
forall a. Word64 -> Id a
Id (Either [Char] Word64 -> Either [Char] (Id a))
-> (ByteString -> Either [Char] Word64)
-> ByteString
-> Either [Char] (Id a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Either [Char] Word64
forall a. Read a => [Char] -> Either [Char] a
readEither ([Char] -> Either [Char] Word64)
-> (ByteString -> [Char]) -> ByteString -> Either [Char] Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
CByteString.unpack)

instance Typeable a => SQL.Result (Id a)

instance SQL.ToField (Id a) where
  toField :: Id a -> ByteString
toField = [Char] -> ByteString
forall a. IsString a => [Char] -> a
fromString ([Char] -> ByteString) -> (Id a -> [Char]) -> Id a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> [Char]
forall a. Show a => a -> [Char]
show (Word64 -> [Char]) -> (Id a -> Word64) -> Id a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id a -> Word64
forall a. Id a -> Word64
fromId

instance SQL.Param (Id a)

-- | A single row.
data Row a = Row
  { -- | Row identifier.
    forall a. Row a -> Id a
rowId :: Id a
    -- | Row data.
  , forall a. Row a -> a
rowData :: a
    } deriving (Row a -> Row a -> Bool
(Row a -> Row a -> Bool) -> (Row a -> Row a -> Bool) -> Eq (Row a)
forall a. Eq a => Row a -> Row a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Row a -> Row a -> Bool
== :: Row a -> Row a -> Bool
$c/= :: forall a. Eq a => Row a -> Row a -> Bool
/= :: Row a -> Row a -> Bool
Eq, Int -> Row a -> ShowS
[Row a] -> ShowS
Row a -> [Char]
(Int -> Row a -> ShowS)
-> (Row a -> [Char]) -> ([Row a] -> ShowS) -> Show (Row a)
forall a. Show a => Int -> Row a -> ShowS
forall a. Show a => [Row a] -> ShowS
forall a. Show a => Row a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Row a -> ShowS
showsPrec :: Int -> Row a -> ShowS
$cshow :: forall a. Show a => Row a -> [Char]
show :: Row a -> [Char]
$cshowList :: forall a. Show a => [Row a] -> ShowS
showList :: [Row a] -> ShowS
Show)

instance FromJSON a => FromJSON (Row a) where
  parseJSON :: Value -> Parser (Row a)
parseJSON = [Char] -> (Object -> Parser (Row a)) -> Value -> Parser (Row a)
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
JSON.withObject [Char]
"Row" ((Object -> Parser (Row a)) -> Value -> Parser (Row a))
-> (Object -> Parser (Row a)) -> Value -> Parser (Row a)
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    (Id a -> a -> Row a) -> Parser (Id a) -> Parser a -> Parser (Row a)
forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Id a -> a -> Row a
forall a. Id a -> a -> Row a
Row (Object
o Object -> Key -> Parser (Id a)
forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Key
"id") (Object
o Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Key
"data")

instance ToJSON a => ToJSON (Row a) where
  toJSON :: Row a -> Value
toJSON (Row Id a
i a
x) = [Pair] -> Value
JSON.object [Key
"id" Key -> Id a -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= Id a
i, Key
"data" Key -> a -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= a
x]

-- | A MySQL table with two columns:
--
-- +----------------------------+-----------+
-- |             id             |    data   |
-- +============================+===========+
-- | Row identifier (type 'Id') | JSON data |
-- +----------------------------+-----------+
--
-- The type parameter indicates the type of data
--  stored in the table.
data JSONTable a = JSONTable
  { -- | Table name.
    forall a. JSONTable a -> [Char]
tableName :: String
    }

tableSpecs :: String
tableSpecs :: [Char]
tableSpecs = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [Char]
"("
  , [Char]
"id BIGINT UNSIGNED NOT NULL PRIMARY KEY AUTO_INCREMENT"
  , [Char]
", "
  , [Char]
"data JSON NOT NULL"
  , [Char]
") ENGINE=InnoDB"
    ]

-- | Create a new JSON table in a MySQL database.
createTable
  :: SQL.Connection -- ^ MySQL database connection.
  -> Bool -- ^ Fail if table already exists.
  -> String -- ^ Table name.
  -> IO (JSONTable a)
createTable :: forall a. Connection -> Bool -> [Char] -> IO (JSONTable a)
createTable Connection
conn Bool
failIfExists [Char]
name = do
  let ifNotExists :: [Char]
ifNotExists = if Bool
failIfExists then [Char]
" " else [Char]
" IF NOT EXISTS "
      query :: [Char]
query = [Char]
"CREATE TABLE" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
ifNotExists [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"`" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"` " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
tableSpecs
  _ <- Connection -> Query -> () -> IO Int64
forall q. QueryParams q => Connection -> Query -> q -> IO Int64
SQL.execute Connection
conn ([Char] -> Query
forall a. IsString a => [Char] -> a
fromString [Char]
query) ()
  pure $ JSONTable
    { tableName = name
      }

-- | Delete a JSON table from a MySQL database, together with all of its content.
deleteTable
  :: SQL.Connection -- ^ MySQL database connection.
  -> Bool -- ^ Fail if table doesn't exist.
  -> JSONTable a 
  -> IO ()
deleteTable :: forall a. Connection -> Bool -> JSONTable a -> IO ()
deleteTable Connection
conn Bool
failIfNotExist JSONTable a
table = do
  let ifExists :: [Char]
ifExists = if Bool
failIfNotExist then [Char]
" " else [Char]
" IF EXISTS "
      query :: [Char]
query = [Char]
"DROP TABLE" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
ifExists [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"`" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ JSONTable a -> [Char]
forall a. JSONTable a -> [Char]
tableName JSONTable a
table [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"`"
  _ <- Connection -> Query -> () -> IO Int64
forall q. QueryParams q => Connection -> Query -> q -> IO Int64
SQL.execute Connection
conn ([Char] -> Query
forall a. IsString a => [Char] -> a
fromString [Char]
query) ()
  pure ()

-- | JSON serialization helper.
newtype AsJSON a = AsJSON { forall a. AsJSON a -> a
asJSON :: a }

instance FromJSON a => SQL.FromField (AsJSON a) where
  fromField :: ([Type], ByteString -> Either [Char] (AsJSON a))
fromField = ([Type
SQLBase.Json], (a -> AsJSON a) -> Either [Char] a -> Either [Char] (AsJSON a)
forall a b. (a -> b) -> Either [Char] a -> Either [Char] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> AsJSON a
forall a. a -> AsJSON a
AsJSON (Either [Char] a -> Either [Char] (AsJSON a))
-> (ByteString -> Either [Char] a)
-> ByteString
-> Either [Char] (AsJSON a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [Char] a
forall a. FromJSON a => ByteString -> Either [Char] a
JSON.eitherDecodeStrict)

instance ToJSON a => SQL.ToField (AsJSON a) where
#if MIN_VERSION_bytestring(0,11,0)
  toField :: AsJSON a -> ByteString
toField = LazyByteString -> ByteString
ByteString.toStrict (LazyByteString -> ByteString)
-> (AsJSON a -> LazyByteString) -> AsJSON a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
JSON.encode (a -> LazyByteString)
-> (AsJSON a -> a) -> AsJSON a -> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AsJSON a -> a
forall a. AsJSON a -> a
asJSON
#else
  toField = LazyByteString.toStrict . JSON.encode . asJSON
#endif

instance (Typeable a, FromJSON a) => SQL.Result (AsJSON a)
instance ToJSON a => SQL.Param (AsJSON a)

-- | Insert a new row into a table.
--
--   /Warning:/ It is recommended not to call 'insert' with the same 'SQL.Connection'
--   argument from multiple threads. The 'Id's returned might get mixed up.
--   If you need to call 'insert' from multiple threads, use a different
--   'SQL.Connection' on each thread.
insert
  :: ToJSON a
  => SQL.Connection -- ^ MySQL database connection.
  -> JSONTable a -- ^ Table to insert the new row.
  -> a -- ^ Data for the new row.
  -> IO (Id a) -- ^ Identifier of the new row.
insert :: forall a. ToJSON a => Connection -> JSONTable a -> a -> IO (Id a)
insert Connection
conn JSONTable a
table a
x = do
  let query :: [Char]
query = [Char]
"INSERT INTO `" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ JSONTable a -> [Char]
forall a. JSONTable a -> [Char]
tableName JSONTable a
table [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"` (data) VALUES (?)"
  _ <- Connection -> Query -> Only (AsJSON a) -> IO Int64
forall q. QueryParams q => Connection -> Query -> q -> IO Int64
SQL.execute Connection
conn ([Char] -> Query
forall a. IsString a => [Char] -> a
fromString [Char]
query) (Only (AsJSON a) -> IO Int64) -> Only (AsJSON a) -> IO Int64
forall a b. (a -> b) -> a -> b
$ AsJSON a -> Only (AsJSON a)
forall a. a -> Only a
SQL.Only (AsJSON a -> Only (AsJSON a)) -> AsJSON a -> Only (AsJSON a)
forall a b. (a -> b) -> a -> b
$ a -> AsJSON a
forall a. a -> AsJSON a
AsJSON a
x
  Id <$> SQL.insertID conn

-- | Lookup a row in a table.
lookup
  :: (Typeable a, FromJSON a)
  => SQL.Connection -- ^ MySQL database connection.
  -> JSONTable a -- ^ Table for lookup.
  -> Id a -- ^ Identifier to use for the table lookup.
  -> IO (Maybe a)
lookup :: forall a.
(Typeable a, FromJSON a) =>
Connection -> JSONTable a -> Id a -> IO (Maybe a)
lookup Connection
conn JSONTable a
table Id a
i = do
  let query :: [Char]
query = [Char]
"SELECT data FROM `" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ JSONTable a -> [Char]
forall a. JSONTable a -> [Char]
tableName JSONTable a
table [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"` WHERE id=?"
  (Only (AsJSON a) -> a) -> Maybe (Only (AsJSON a)) -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AsJSON a -> a
forall a. AsJSON a -> a
asJSON (AsJSON a -> a)
-> (Only (AsJSON a) -> AsJSON a) -> Only (AsJSON a) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only (AsJSON a) -> AsJSON a
forall a. Only a -> a
SQL.fromOnly) (Maybe (Only (AsJSON a)) -> Maybe a)
-> ([Only (AsJSON a)] -> Maybe (Only (AsJSON a)))
-> [Only (AsJSON a)]
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Only (AsJSON a)] -> Maybe (Only (AsJSON a))
forall a. [a] -> Maybe a
listToMaybe ([Only (AsJSON a)] -> Maybe a)
-> IO [Only (AsJSON a)] -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Query -> Only (Id a) -> IO [Only (AsJSON a)]
forall q r.
(QueryParams q, QueryResults r) =>
Connection -> Query -> q -> IO [r]
SQL.query Connection
conn ([Char] -> Query
forall a. IsString a => [Char] -> a
fromString [Char]
query) (Id a -> Only (Id a)
forall a. a -> Only a
SQL.Only Id a
i)

-- | Update a row by applying the supplied function. If the row doesn't exist,
--   it does nothing.
adjust
  :: (Typeable a, FromJSON a, ToJSON a)
  => SQL.Connection -- ^ MySQL database connection.
  -> JSONTable a
  -> (a -> IO a) -- ^ Update function.
  -> Id a
  -> IO ()
adjust :: forall a.
(Typeable a, FromJSON a, ToJSON a) =>
Connection -> JSONTable a -> (a -> IO a) -> Id a -> IO ()
adjust Connection
conn JSONTable a
table a -> IO a
f Id a
i = Connection -> IO () -> IO ()
forall a. Connection -> IO a -> IO a
SQL.withTransaction Connection
conn (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  let query1 :: [Char]
query1 = [Char]
"SELECT data FROM `" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ JSONTable a -> [Char]
forall a. JSONTable a -> [Char]
tableName JSONTable a
table [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"` WHERE id=? FOR SHARE"
  mr <- [Only (AsJSON a)] -> Maybe (Only (AsJSON a))
forall a. [a] -> Maybe a
listToMaybe ([Only (AsJSON a)] -> Maybe (Only (AsJSON a)))
-> IO [Only (AsJSON a)] -> IO (Maybe (Only (AsJSON a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Query -> Only (Id a) -> IO [Only (AsJSON a)]
forall q r.
(QueryParams q, QueryResults r) =>
Connection -> Query -> q -> IO [r]
SQL.query Connection
conn ([Char] -> Query
forall a. IsString a => [Char] -> a
fromString [Char]
query1) (Id a -> Only (Id a)
forall a. a -> Only a
SQL.Only Id a
i)
  forM_ mr $ \(SQL.Only (AsJSON a
x)) -> do
    y <- a -> IO a
f a
x
    let query2 = [Char]
"UPDATE `" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ JSONTable a -> [Char]
forall a. JSONTable a -> [Char]
tableName JSONTable a
table [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"` SET data=? WHERE id=?"
    _ <- SQL.execute conn (fromString query2) (AsJSON y,i)
    pure ()

-- | Replace the current value of a row. It does nothing if the row doesn't exist.
replace
  :: ToJSON a
  => SQL.Connection -- ^ MySQL database connection.
  -> JSONTable a
  -> Id a -- ^ Row identifier.
  -> a -- ^ New value.
  -> IO ()
replace :: forall a.
ToJSON a =>
Connection -> JSONTable a -> Id a -> a -> IO ()
replace Connection
conn JSONTable a
table Id a
i a
x = do
  let query :: [Char]
query = [Char]
"UPDATE `" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ JSONTable a -> [Char]
forall a. JSONTable a -> [Char]
tableName JSONTable a
table [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"` SET data=? WHERE id=?"
  _ <- Connection -> Query -> (AsJSON a, Id a) -> IO Int64
forall q. QueryParams q => Connection -> Query -> q -> IO Int64
SQL.execute Connection
conn ([Char] -> Query
forall a. IsString a => [Char] -> a
fromString [Char]
query) (a -> AsJSON a
forall a. a -> AsJSON a
AsJSON a
x,Id a
i)
  pure ()

-- | Delete a row from a table. It does nothing if the row doesn't exist.
delete
  :: SQL.Connection -- ^ MySQL database connection.
  -> JSONTable a -- ^ Table to delete the row from.
  -> Id a -- ^ Identifier of the row to delete.
  -> IO ()
delete :: forall a. Connection -> JSONTable a -> Id a -> IO ()
delete Connection
conn JSONTable a
table Id a
i = do
  let query :: [Char]
query = [Char]
"DELETE FROM `" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ JSONTable a -> [Char]
forall a. JSONTable a -> [Char]
tableName JSONTable a
table [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"` WHERE id=?"
  _ <- Connection -> Query -> Only (Id a) -> IO Int64
forall q. QueryParams q => Connection -> Query -> q -> IO Int64
SQL.execute Connection
conn ([Char] -> Query
forall a. IsString a => [Char] -> a
fromString [Char]
query) (Only (Id a) -> IO Int64) -> Only (Id a) -> IO Int64
forall a b. (a -> b) -> a -> b
$ Id a -> Only (Id a)
forall a. a -> Only a
SQL.Only Id a
i
  pure ()

-- | Stream all rows using a conduit.
sourceRows
  :: (Typeable a, FromJSON a)
  => SQL.Connection -- ^ MySQL database connection.
  -> JSONTable a -- ^ Table to stream rows from.
  -> ConduitT i (Row a) (ResourceT IO) ()
sourceRows :: forall a i.
(Typeable a, FromJSON a) =>
Connection -> JSONTable a -> ConduitT i (Row a) (ResourceT IO) ()
sourceRows Connection
conn JSONTable a
table = do
  let query :: [Char]
query = [Char]
"SELECT * FROM `" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ JSONTable a -> [Char]
forall a. JSONTable a -> [Char]
tableName JSONTable a
table [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"`"
  IO () -> ConduitT i (Row a) (ResourceT IO) ()
forall a. IO a -> ConduitT i (Row a) (ResourceT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitT i (Row a) (ResourceT IO) ())
-> IO () -> ConduitT i (Row a) (ResourceT IO) ()
forall a b. (a -> b) -> a -> b
$ Connection -> ByteString -> IO ()
SQLBase.query Connection
conn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
forall a. IsString a => [Char] -> a
fromString [Char]
query
  IO Result
-> (Result -> IO ())
-> (Result -> ConduitT i (Row a) (ResourceT IO) ())
-> ConduitT i (Row a) (ResourceT IO) ()
forall (m :: * -> *) a i o r.
MonadResource m =>
IO a -> (a -> IO ()) -> (a -> ConduitT i o m r) -> ConduitT i o m r
Conduit.bracketP (Connection -> IO Result
SQLBase.useResult Connection
conn) Result -> IO ()
SQLBase.freeResult ((Result -> ConduitT i (Row a) (ResourceT IO) ())
 -> ConduitT i (Row a) (ResourceT IO) ())
-> (Result -> ConduitT i (Row a) (ResourceT IO) ())
-> ConduitT i (Row a) (ResourceT IO) ()
forall a b. (a -> b) -> a -> b
$ \Result
result -> do
    fields <- IO [Field] -> ConduitT i (Row a) (ResourceT IO) [Field]
forall a. IO a -> ConduitT i (Row a) (ResourceT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Field] -> ConduitT i (Row a) (ResourceT IO) [Field])
-> IO [Field] -> ConduitT i (Row a) (ResourceT IO) [Field]
forall a b. (a -> b) -> a -> b
$ do
      ncols <- Either Connection Result -> IO Int
SQLBase.fieldCount (Either Connection Result -> IO Int)
-> Either Connection Result -> IO Int
forall a b. (a -> b) -> a -> b
$ Result -> Either Connection Result
forall a b. b -> Either a b
Right Result
result
      when (ncols == 0) $ fail "Query error: Result has no columns."
      SQLBase.fetchFields result
    let loop = do
          row <- IO [Maybe ByteString]
-> ConduitT i (Row a) (ResourceT IO) [Maybe ByteString]
forall a. IO a -> ConduitT i (Row a) (ResourceT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Maybe ByteString]
 -> ConduitT i (Row a) (ResourceT IO) [Maybe ByteString])
-> IO [Maybe ByteString]
-> ConduitT i (Row a) (ResourceT IO) [Maybe ByteString]
forall a b. (a -> b) -> a -> b
$ Result -> IO [Maybe ByteString]
SQLBase.fetchRow Result
result
          unless (null row) $ do
            let (i,AsJSON x) = SQL.convertResults fields row
            Conduit.yield $ Row i x
            loop
    loop

-- | Lookup key in an 'Id' table.
newtype Key key = Key key deriving (([Type], ByteString -> Either [Char] (Key key))
([Type], ByteString -> Either [Char] (Key key))
-> FromField (Key key)
forall a. ([Type], ByteString -> Either [Char] a) -> FromField a
forall key.
FromField key =>
([Type], ByteString -> Either [Char] (Key key))
$cfromField :: forall key.
FromField key =>
([Type], ByteString -> Either [Char] (Key key))
fromField :: ([Type], ByteString -> Either [Char] (Key key))
SQL.FromField, Key key -> ByteString
(Key key -> ByteString) -> ToField (Key key)
forall key. ToField key => Key key -> ByteString
forall a. (a -> ByteString) -> ToField a
$ctoField :: forall key. ToField key => Key key -> ByteString
toField :: Key key -> ByteString
SQL.ToField)

instance (Typeable key, SQL.FromField key) => SQL.Result (Key key)
instance SQL.ToField key => SQL.Param (Key key)

-- | Table that stores a map from keys to row identifiers from
--   some 'JSONTable'. It has the following shape:
--
-- +------------------------+----------------------------+
-- |          key           |            id              |
-- +========================+============================+
-- | User-provided key type | Row identifier (type 'Id') |
-- +------------------------+----------------------------+
--
data IdTable key a = IdTable
  { -- | Table name.
    forall key a. IdTable key a -> [Char]
idTableName :: String
    }

typeToSpec :: SQLBase.Type -> String
typeToSpec :: Type -> [Char]
typeToSpec Type
SQLBase.Tiny = [Char]
"TINYINT"
typeToSpec Type
SQLBase.Short = [Char]
"SMALLINT"
typeToSpec Type
SQLBase.Int24 = [Char]
"MEDIUMINT"
typeToSpec Type
SQLBase.Long = [Char]
"INT"
typeToSpec Type
SQLBase.LongLong = [Char]
"BIGINT"
typeToSpec Type
SQLBase.NewDate = [Char]
"DATE"
typeToSpec Type
SQLBase.NewDecimal = [Char]
"DECIMAL"
typeToSpec Type
SQLBase.VarChar = [Char]
"VARCHAR(255)"
typeToSpec Type
t = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
toUpper ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
t

idTableSpecs :: forall proxy key . SQL.FromField key => proxy key -> String
idTableSpecs :: forall (proxy :: * -> *) key. FromField key => proxy key -> [Char]
idTableSpecs proxy key
_ = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [Char]
"("
  , [Char]
"`key` " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
typeToSpec ([Type] -> Type
forall a. HasCallStack => [a] -> a
head ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ ([Type], ByteString -> Either [Char] key) -> [Type]
forall a b. (a, b) -> a
fst (forall a. FromField a => ([Type], ByteString -> Either [Char] a)
SQL.fromField @key)) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" NOT NULL PRIMARY KEY"
  , [Char]
", "
  , [Char]
"id BIGINT UNSIGNED NOT NULL"
  , [Char]
") ENGINE=InnoDB"
    ]

-- | Create a new Id table in a MySQL database.
--
--   The type of the @key@ column will be set to the first type listed in
--   'SQL.fromField'.
createIdTable
  :: forall key a
   . SQL.FromField key
  => SQL.Connection -- ^ MySQL database connection.
  -> Bool -- ^ Fail if table already exists.
  -> String -- ^ Table name.
  -> IO (IdTable key a)
createIdTable :: forall key a.
FromField key =>
Connection -> Bool -> [Char] -> IO (IdTable key a)
createIdTable Connection
conn Bool
failIfExists [Char]
name = do
  let ifNotExists :: [Char]
ifNotExists = if Bool
failIfExists then [Char]
" " else [Char]
" IF NOT EXISTS "
      query :: [Char]
query = [Char]
"CREATE TABLE" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
ifNotExists [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"`" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"` " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Proxy key -> [Char]
forall (proxy :: * -> *) key. FromField key => proxy key -> [Char]
idTableSpecs (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @key)
  _ <- Connection -> Query -> () -> IO Int64
forall q. QueryParams q => Connection -> Query -> q -> IO Int64
SQL.execute Connection
conn ([Char] -> Query
forall a. IsString a => [Char] -> a
fromString [Char]
query) ()
  pure $ IdTable
    { idTableName = name
      }

-- | Delete an Id table from a MySQL database, together with all of its content.
deleteIdTable
  :: SQL.Connection -- ^ MySQL database connection.
  -> Bool -- ^ Fail if table doesn't exist.
  -> IdTable key a 
  -> IO ()
deleteIdTable :: forall key a. Connection -> Bool -> IdTable key a -> IO ()
deleteIdTable Connection
conn Bool
failIfNotExist IdTable key a
itable = do
  let ifExists :: [Char]
ifExists = if Bool
failIfNotExist then [Char]
" " else [Char]
" IF EXISTS "
      query :: [Char]
query = [Char]
"DROP TABLE" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
ifExists [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"`" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ IdTable key a -> [Char]
forall key a. IdTable key a -> [Char]
idTableName IdTable key a
itable [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"`"
  _ <- Connection -> Query -> () -> IO Int64
forall q. QueryParams q => Connection -> Query -> q -> IO Int64
SQL.execute Connection
conn ([Char] -> Query
forall a. IsString a => [Char] -> a
fromString [Char]
query) ()
  pure ()

-- | Insert a new Id into an Id table.
insertId
  :: SQL.ToField key
  => SQL.Connection
  -> IdTable key a
  -> key
  -> Id a
  -> IO ()
insertId :: forall key a.
ToField key =>
Connection -> IdTable key a -> key -> Id a -> IO ()
insertId Connection
conn IdTable key a
itable key
k Id a
i = do
  let query :: [Char]
query = [Char]
"INSERT INTO `" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ IdTable key a -> [Char]
forall key a. IdTable key a -> [Char]
idTableName IdTable key a
itable [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"` (`key`,id) VALUES (?,?)"
  _ <- Connection -> Query -> (Key key, Id a) -> IO Int64
forall q. QueryParams q => Connection -> Query -> q -> IO Int64
SQL.execute Connection
conn ([Char] -> Query
forall a. IsString a => [Char] -> a
fromString [Char]
query) (key -> Key key
forall key. key -> Key key
Key key
k, Id a
i)
  pure ()

-- | Id table lookup.
lookupId
  :: (SQL.ToField key, Typeable a)
  => SQL.Connection
  -> IdTable key a
  -> key
  -> IO (Maybe (Id a))
lookupId :: forall key a.
(ToField key, Typeable a) =>
Connection -> IdTable key a -> key -> IO (Maybe (Id a))
lookupId Connection
conn IdTable key a
itable key
k = do
  let query :: [Char]
query = [Char]
"SELECT id FROM `" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ IdTable key a -> [Char]
forall key a. IdTable key a -> [Char]
idTableName IdTable key a
itable [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"` WHERE `key`=?"
  (Only (Id a) -> Id a) -> Maybe (Only (Id a)) -> Maybe (Id a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Only (Id a) -> Id a
forall a. Only a -> a
SQL.fromOnly (Maybe (Only (Id a)) -> Maybe (Id a))
-> ([Only (Id a)] -> Maybe (Only (Id a)))
-> [Only (Id a)]
-> Maybe (Id a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Only (Id a)] -> Maybe (Only (Id a))
forall a. [a] -> Maybe a
listToMaybe ([Only (Id a)] -> Maybe (Id a))
-> IO [Only (Id a)] -> IO (Maybe (Id a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Query -> Only (Key key) -> IO [Only (Id a)]
forall q r.
(QueryParams q, QueryResults r) =>
Connection -> Query -> q -> IO [r]
SQL.query Connection
conn ([Char] -> Query
forall a. IsString a => [Char] -> a
fromString [Char]
query) (Key key -> Only (Key key)
forall a. a -> Only a
SQL.Only (Key key -> Only (Key key)) -> Key key -> Only (Key key)
forall a b. (a -> b) -> a -> b
$ key -> Key key
forall key. key -> Key key
Key key
k)

-- | Update an 'Id' by applying the supplied function. If the key is not found,
--   it does nothing.
adjustId
  :: (SQL.ToField key, Typeable a)
  => SQL.Connection -- ^ MySQL database connection.
  -> IdTable key a
  -> (Id a -> IO (Id a)) -- ^ Update function.
  -> key
  -> IO ()
adjustId :: forall key a.
(ToField key, Typeable a) =>
Connection -> IdTable key a -> (Id a -> IO (Id a)) -> key -> IO ()
adjustId Connection
conn IdTable key a
itable Id a -> IO (Id a)
f key
k = Connection -> IO () -> IO ()
forall a. Connection -> IO a -> IO a
SQL.withTransaction Connection
conn (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  let query1 :: [Char]
query1 = [Char]
"SELECT id FROM `" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ IdTable key a -> [Char]
forall key a. IdTable key a -> [Char]
idTableName IdTable key a
itable [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"` WHERE `key`=? FOR SHARE"
  mr <- [Only (Id a)] -> Maybe (Only (Id a))
forall a. [a] -> Maybe a
listToMaybe ([Only (Id a)] -> Maybe (Only (Id a)))
-> IO [Only (Id a)] -> IO (Maybe (Only (Id a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Query -> Only (Key key) -> IO [Only (Id a)]
forall q r.
(QueryParams q, QueryResults r) =>
Connection -> Query -> q -> IO [r]
SQL.query Connection
conn ([Char] -> Query
forall a. IsString a => [Char] -> a
fromString [Char]
query1) (Key key -> Only (Key key)
forall a. a -> Only a
SQL.Only (Key key -> Only (Key key)) -> Key key -> Only (Key key)
forall a b. (a -> b) -> a -> b
$ key -> Key key
forall key. key -> Key key
Key key
k)
  forM_ mr $ \(SQL.Only Id a
i) -> do
    j <- Id a -> IO (Id a)
f Id a
i
    let query2 = [Char]
"UPDATE `" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ IdTable key a -> [Char]
forall key a. IdTable key a -> [Char]
idTableName IdTable key a
itable [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"` SET id=? WHERE `key`=?"
    _ <- SQL.execute conn (fromString query2) (j,Key k)
    pure ()

-- | Alter an 'Id' by applying the supplied function, either inserting it, removing
--   it, or updating it.
alterId
  :: (SQL.ToField key, Typeable a)
  => SQL.Connection -- ^ MySQL database connection.
  -> IdTable key a
  -> (Maybe (Id a) -> IO (Maybe (Id a))) -- ^ Update function.
  -> key
  -> IO ()
alterId :: forall key a.
(ToField key, Typeable a) =>
Connection
-> IdTable key a
-> (Maybe (Id a) -> IO (Maybe (Id a)))
-> key
-> IO ()
alterId Connection
conn IdTable key a
itable Maybe (Id a) -> IO (Maybe (Id a))
f key
k = Connection -> IO () -> IO ()
forall a. Connection -> IO a -> IO a
SQL.withTransaction Connection
conn (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  let query1 :: [Char]
query1 = [Char]
"SELECT id FROM `" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ IdTable key a -> [Char]
forall key a. IdTable key a -> [Char]
idTableName IdTable key a
itable [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"` WHERE `key`=? FOR SHARE"
  mi <- (Only (Id a) -> Id a) -> Maybe (Only (Id a)) -> Maybe (Id a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Only (Id a) -> Id a
forall a. Only a -> a
SQL.fromOnly (Maybe (Only (Id a)) -> Maybe (Id a))
-> ([Only (Id a)] -> Maybe (Only (Id a)))
-> [Only (Id a)]
-> Maybe (Id a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Only (Id a)] -> Maybe (Only (Id a))
forall a. [a] -> Maybe a
listToMaybe ([Only (Id a)] -> Maybe (Id a))
-> IO [Only (Id a)] -> IO (Maybe (Id a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Query -> Only (Key key) -> IO [Only (Id a)]
forall q r.
(QueryParams q, QueryResults r) =>
Connection -> Query -> q -> IO [r]
SQL.query Connection
conn ([Char] -> Query
forall a. IsString a => [Char] -> a
fromString [Char]
query1) (Key key -> Only (Key key)
forall a. a -> Only a
SQL.Only (Key key -> Only (Key key)) -> Key key -> Only (Key key)
forall a b. (a -> b) -> a -> b
$ key -> Key key
forall key. key -> Key key
Key key
k)
  case mi of
    Maybe (Id a)
Nothing -> do
      mj <- Maybe (Id a) -> IO (Maybe (Id a))
f Maybe (Id a)
mi
      case mj of
        Maybe (Id a)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Id a
j -> do
          let query2 :: [Char]
query2 = [Char]
"INSERT INTO `" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ IdTable key a -> [Char]
forall key a. IdTable key a -> [Char]
idTableName IdTable key a
itable [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"` (`key`,id) VALUES (?,?)"
          _ <- Connection -> Query -> (Key key, Id a) -> IO Int64
forall q. QueryParams q => Connection -> Query -> q -> IO Int64
SQL.execute Connection
conn ([Char] -> Query
forall a. IsString a => [Char] -> a
fromString [Char]
query2) (key -> Key key
forall key. key -> Key key
Key key
k,Id a
j)
          pure ()
    Maybe (Id a)
_ -> do
      mj <- Maybe (Id a) -> IO (Maybe (Id a))
f Maybe (Id a)
mi
      case mj of
        Maybe (Id a)
Nothing -> do
          let query2 :: [Char]
query2 = [Char]
"DELETE FROM `" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ IdTable key a -> [Char]
forall key a. IdTable key a -> [Char]
idTableName IdTable key a
itable [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"` WHERE `key`=?"
          _ <- Connection -> Query -> Only (Key key) -> IO Int64
forall q. QueryParams q => Connection -> Query -> q -> IO Int64
SQL.execute Connection
conn ([Char] -> Query
forall a. IsString a => [Char] -> a
fromString [Char]
query2) (Only (Key key) -> IO Int64) -> Only (Key key) -> IO Int64
forall a b. (a -> b) -> a -> b
$ Key key -> Only (Key key)
forall a. a -> Only a
SQL.Only (Key key -> Only (Key key)) -> Key key -> Only (Key key)
forall a b. (a -> b) -> a -> b
$ key -> Key key
forall key. key -> Key key
Key key
k
          pure ()
        Just Id a
j -> do
          let query2 :: [Char]
query2 = [Char]
"UPDATE `" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ IdTable key a -> [Char]
forall key a. IdTable key a -> [Char]
idTableName IdTable key a
itable [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"` SET id=? WHERE `key`=?"
          _ <- Connection -> Query -> (Id a, Key key) -> IO Int64
forall q. QueryParams q => Connection -> Query -> q -> IO Int64
SQL.execute Connection
conn ([Char] -> Query
forall a. IsString a => [Char] -> a
fromString [Char]
query2) (Id a
j,key -> Key key
forall key. key -> Key key
Key key
k)
          pure ()

-- | Delete an Id from and Id table. It does nothing if the key is not found.
deleteId
  :: SQL.ToField key
  => SQL.Connection
  -> IdTable key a
  -> key
  -> IO ()
deleteId :: forall key a.
ToField key =>
Connection -> IdTable key a -> key -> IO ()
deleteId Connection
conn IdTable key a
itable key
k = do
  let query :: [Char]
query = [Char]
"DELETE FROM `" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ IdTable key a -> [Char]
forall key a. IdTable key a -> [Char]
idTableName IdTable key a
itable [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"` WHERE `key`=?"
  _ <- Connection -> Query -> Only (Key key) -> IO Int64
forall q. QueryParams q => Connection -> Query -> q -> IO Int64
SQL.execute Connection
conn ([Char] -> Query
forall a. IsString a => [Char] -> a
fromString [Char]
query) (Only (Key key) -> IO Int64) -> Only (Key key) -> IO Int64
forall a b. (a -> b) -> a -> b
$ Key key -> Only (Key key)
forall a. a -> Only a
SQL.Only (Key key -> Only (Key key)) -> Key key -> Only (Key key)
forall a b. (a -> b) -> a -> b
$ key -> Key key
forall key. key -> Key key
Key key
k
  pure ()

-- | Replace the 'Id' associated to the given key. It does nothing if the key
--   isn't found.
replaceId
  :: SQL.ToField key
  => SQL.Connection
  -> IdTable key a
  -> key
  -> Id a
  -> IO ()
replaceId :: forall key a.
ToField key =>
Connection -> IdTable key a -> key -> Id a -> IO ()
replaceId Connection
conn IdTable key a
itable key
k Id a
i = do
  let query :: [Char]
query = [Char]
"UPDATE `" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ IdTable key a -> [Char]
forall key a. IdTable key a -> [Char]
idTableName IdTable key a
itable [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"` SET id=? WHERE `key`=?"
  _ <- Connection -> Query -> (Id a, Key key) -> IO Int64
forall q. QueryParams q => Connection -> Query -> q -> IO Int64
SQL.execute Connection
conn ([Char] -> Query
forall a. IsString a => [Char] -> a
fromString [Char]
query) (Id a
i,key -> Key key
forall key. key -> Key key
Key key
k)
  pure ()

-- | Move an Id from one key to another. This fails if the original key
--   doesn't exist or the target key already exists.
moveId
  :: (SQL.ToField key, Typeable a)
  => SQL.Connection
  -> IdTable key a
  -> key -- ^ Original key
  -> key -- ^ New key
  -> IO ()
moveId :: forall key a.
(ToField key, Typeable a) =>
Connection -> IdTable key a -> key -> key -> IO ()
moveId Connection
conn IdTable key a
itable key
k key
k' = do
  mi <- Connection -> IdTable key a -> key -> IO (Maybe (Id a))
forall key a.
(ToField key, Typeable a) =>
Connection -> IdTable key a -> key -> IO (Maybe (Id a))
lookupId Connection
conn IdTable key a
itable key
k
  case mi of
    Just Id a
i -> Connection -> IO () -> IO ()
forall a. Connection -> IO a -> IO a
SQL.withTransaction Connection
conn (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Connection -> IdTable key a -> key -> IO ()
forall key a.
ToField key =>
Connection -> IdTable key a -> key -> IO ()
deleteId Connection
conn IdTable key a
itable key
k
      Connection -> IdTable key a -> key -> Id a -> IO ()
forall key a.
ToField key =>
Connection -> IdTable key a -> key -> Id a -> IO ()
insertId Connection
conn IdTable key a
itable key
k' Id a
i
    Maybe (Id a)
Nothing -> [Char] -> IO ()
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Key not found: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
forall a. Show a => a -> [Char]
show (key -> ByteString
forall a. ToField a => a -> ByteString
SQL.toField key
k) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"."

-- | Stream all ids using a conduit.
sourceIds
  :: (Typeable key, SQL.FromField key, Typeable a)
  => SQL.Connection -- ^ MySQL database connection.
  -> IdTable key a -- ^ Table to stream ids from.
  -> ConduitT i (key, Id a) (ResourceT IO) ()
sourceIds :: forall key a i.
(Typeable key, FromField key, Typeable a) =>
Connection
-> IdTable key a -> ConduitT i (key, Id a) (ResourceT IO) ()
sourceIds Connection
conn IdTable key a
itable = do
  let query :: [Char]
query = [Char]
"SELECT * FROM `" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ IdTable key a -> [Char]
forall key a. IdTable key a -> [Char]
idTableName IdTable key a
itable [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"`"
  IO () -> ConduitT i (key, Id a) (ResourceT IO) ()
forall a. IO a -> ConduitT i (key, Id a) (ResourceT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitT i (key, Id a) (ResourceT IO) ())
-> IO () -> ConduitT i (key, Id a) (ResourceT IO) ()
forall a b. (a -> b) -> a -> b
$ Connection -> ByteString -> IO ()
SQLBase.query Connection
conn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
forall a. IsString a => [Char] -> a
fromString [Char]
query
  IO Result
-> (Result -> IO ())
-> (Result -> ConduitT i (key, Id a) (ResourceT IO) ())
-> ConduitT i (key, Id a) (ResourceT IO) ()
forall (m :: * -> *) a i o r.
MonadResource m =>
IO a -> (a -> IO ()) -> (a -> ConduitT i o m r) -> ConduitT i o m r
Conduit.bracketP (Connection -> IO Result
SQLBase.useResult Connection
conn) Result -> IO ()
SQLBase.freeResult ((Result -> ConduitT i (key, Id a) (ResourceT IO) ())
 -> ConduitT i (key, Id a) (ResourceT IO) ())
-> (Result -> ConduitT i (key, Id a) (ResourceT IO) ())
-> ConduitT i (key, Id a) (ResourceT IO) ()
forall a b. (a -> b) -> a -> b
$ \Result
result -> do
    fields <- IO [Field] -> ConduitT i (key, Id a) (ResourceT IO) [Field]
forall a. IO a -> ConduitT i (key, Id a) (ResourceT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Field] -> ConduitT i (key, Id a) (ResourceT IO) [Field])
-> IO [Field] -> ConduitT i (key, Id a) (ResourceT IO) [Field]
forall a b. (a -> b) -> a -> b
$ do
      ncols <- Either Connection Result -> IO Int
SQLBase.fieldCount (Either Connection Result -> IO Int)
-> Either Connection Result -> IO Int
forall a b. (a -> b) -> a -> b
$ Result -> Either Connection Result
forall a b. b -> Either a b
Right Result
result
      when (ncols == 0) $ fail "Query error: Result has no columns."
      SQLBase.fetchFields result
    let loop = do
          row <- IO [Maybe ByteString]
-> ConduitT i (key, Id a) (ResourceT IO) [Maybe ByteString]
forall a. IO a -> ConduitT i (key, Id a) (ResourceT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Maybe ByteString]
 -> ConduitT i (key, Id a) (ResourceT IO) [Maybe ByteString])
-> IO [Maybe ByteString]
-> ConduitT i (key, Id a) (ResourceT IO) [Maybe ByteString]
forall a b. (a -> b) -> a -> b
$ Result -> IO [Maybe ByteString]
SQLBase.fetchRow Result
result
          unless (null row) $ do
            let (Key k,i) = SQL.convertResults fields row
            Conduit.yield (k,i)
            loop
    loop