{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module BDCS.DB where
import Control.Monad(unless)
import Control.Monad.Except(MonadError, throwError)
import Control.Monad.IO.Class(MonadIO)
import Control.Monad.Logger(NoLoggingT)
import Control.Monad.Trans.Resource(MonadBaseControl, ResourceT)
import qualified Data.Aeson as Aeson
import Data.Aeson((.:), (.=))
import Data.ByteString(ByteString)
import Data.Int(Int64)
import Data.Maybe(fromMaybe, listToMaybe)
import qualified Data.Text as T
import Data.Time(UTCTime)
import Database.Esqueleto(Esqueleto, Entity, Key, PersistEntity, PersistField, SqlBackend, SqlPersistT, ToBackendKey, Value,
(==.), entityVal, insert, isNothing, val, unValue)
import Database.Persist.Sql(rawSql, unSingle)
import Database.Persist.Sqlite(runSqlite)
import Database.Persist.TH
import BDCS.KeyType
import BDCS.ReqType
{-# ANN module ("HLint: ignore Use module export list" :: String) #-}
{-# ANN module ("HLint: ignore Use isNothing" :: String) #-}
schemaVersion :: Int64
schemaVersion = 4
getDbVersion :: (MonadError String m, MonadIO m) => SqlPersistT m Int64
getDbVersion = rawSql "pragma user_version" [] >>= \case
[] -> throwError "Database does not contain a user_version"
v:_ -> return $ unSingle v
checkDbVersion :: (MonadError String m, MonadIO m) => SqlPersistT m ()
checkDbVersion = do
userVersion <- getDbVersion
unless (userVersion == schemaVersion) $ throwError $
"Database version " ++ show userVersion ++ " does not match expected version " ++ show schemaVersion ++
", please re-import your data"
checkAndRunSqlite :: (MonadError String m, MonadBaseControl IO m, MonadIO m) =>
T.Text -> SqlPersistT (NoLoggingT (ResourceT m)) a -> m a
checkAndRunSqlite db action = runSqlite db (checkDbVersion >> action)
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Projects
name T.Text
summary T.Text
description T.Text
homepage T.Text Maybe
upstream_vcs T.Text
NameKey name
deriving Eq Show
Sources
project_id ProjectsId
license T.Text
version T.Text
source_ref T.Text
deriving Eq Show
Builds
source_id SourcesId
epoch Int default=0
release T.Text
arch T.Text
build_time UTCTime
changelog ByteString
build_config_ref T.Text
build_env_ref T.Text
deriving Eq Show
BuildSignatures
build_id BuildsId
signature_type T.Text
signature_data ByteString
deriving Eq Show
Files
path T.Text
file_user T.Text
file_group T.Text
mtime Int
cs_object ByteString Maybe
mode Int
size Int
target T.Text Maybe
deriving Eq Show
SourceFiles
source_id SourcesId
file_id FilesId
deriving Eq Show
BuildFiles
build_id BuildsId
file_id FilesId
deriving Eq Show
KeyVal
key_value KeyType
val_value T.Text Maybe
ext_value T.Text Maybe
deriving Eq Show
ProjectKeyValues
package_id ProjectsId
key_val_id KeyValId
deriving Eq Show
SourceKeyValues
source_id SourcesId
key_val_id KeyValId
deriving Eq Show
BuildKeyValues
build_id BuildsId
key_val_id KeyValId
deriving Eq Show
FileKeyValues
file_id FilesId
key_val_id KeyValId
deriving Eq Show
Groups
name T.Text
group_type T.Text
build_id BuildsId Maybe
deriving Eq Show
GroupFiles
group_id GroupsId
file_id FilesId
deriving Eq Show
GroupGroups
parent_group_id GroupsId
child_group_id GroupsId
deriving Eq Show
GroupKeyValues
group_id GroupsId
key_val_id KeyValId
deriving Eq Show
Requirements
req_language ReqLanguage
req_context ReqContext
req_strength ReqStrength
req_expr T.Text
deriving Eq Show
GroupRequirements
group_id GroupsId
req_id RequirementsId
deriving Eq Show
Scripts
ty T.Text
body T.Text
trigger_prog T.Text Maybe
trigger_index Int Maybe
trigger_name T.Text Maybe
trigger_version T.Text Maybe
trigger_flags Int Maybe
deriving Eq Show
GroupScripts
group_id GroupsId
script_id ScriptsId
deriving Eq Show
|]
instance Aeson.ToJSON Projects where
toJSON Projects{..} = Aeson.object [
"name" .= projectsName
, "summary" .= projectsSummary
, "description" .= projectsDescription
, "homepage" .= fromMaybe "" projectsHomepage
, "upstream_vcs" .= projectsUpstream_vcs ]
instance Aeson.FromJSON Projects where
parseJSON = Aeson.withObject "Projects" $ \o -> do
projectsName <- o .: "name"
projectsSummary <- o .: "summary"
projectsDescription <- o .: "description"
projectsHomepage <- o .: "homepage"
projectsUpstream_vcs <- o .: "upstream_vcs"
return Projects{..}
instance Aeson.ToJSON KeyVal where
toJSON kv = let
jsonVal :: Maybe Aeson.Value -> Maybe Aeson.Value -> Aeson.Value
jsonVal Nothing _ = Aeson.Bool True
jsonVal (Just v) Nothing = v
jsonVal (Just v) (Just e) = if v == e then v else e
in
jsonVal (Aeson.toJSON <$> keyValVal_value kv)
(Aeson.toJSON <$> keyValExt_value kv)
firstEntityResult :: Monad m => m [Entity a] -> m (Maybe a)
firstEntityResult query =
listToMaybe . map entityVal <$> query
firstKeyResult :: Monad m => m [Value a] -> m (Maybe a)
firstKeyResult query =
listToMaybe . map unValue <$> query
maybeKey :: MonadIO m =>
m b
-> (t -> m b)
-> m (Maybe t)
-> m b
maybeKey def fn value = value >>= \case
Nothing -> def
Just v -> fn v
infix 4 ==?
(==?) :: (PersistField typ, Esqueleto query expr backend) => expr (Value (Maybe typ)) -> Maybe typ -> expr (Value Bool)
(==?) column Nothing = isNothing column
(==?) column value@(Just _) = column ==. val value
orDo :: MonadIO m => m (Maybe b) -> m b -> m b
orDo findFn doFn =
findFn >>= maybe doFn return
orInsert :: (MonadIO m, PersistEntity a, ToBackendKey SqlBackend a) => SqlPersistT m (Maybe (Key a)) -> a -> SqlPersistT m (Key a)
orInsert findFn obj =
findFn >>= maybe (insert obj) return