-- For embedded SQL queries
{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Use maybe" #-}
-- HLint can't figure out where TemplateHaskell is used,
-- even though it throws an error without the pragma.
{-# HLINT ignore "Unused LANGUAGE pragma" #-}

module AirGQL.Utils (
  collectAllErrorsAsText,
  collectErrorList,
  colToFileUrl,
  escDoubleQuotes,
  escSingleQuotes,
  getDbDir,
  getGraphiQLVersion,
  getMainDbPath,
  getOrderOfLinkedList,
  getReadOnlyFilePath,
  getDbIdFromReadOnlyId,
  getSqliteBinaryVersion,
  getSqliteEmbeddedVersion,
  headerJsonContent,
  quoteKeyword,
  quoteText,
  removeIfExists,
  runSqliteCommand,
  throwErr400WithMsg,
  throwErr404WithMsg,
  throwErr500WithMsg,
  withRetryConn,
  DiffKind (..),
) where

import Protolude (
  Applicative (pure),
  ExitCode (ExitFailure, ExitSuccess),
  FilePath,
  IO,
  Maybe (Just, Nothing),
  Monoid (mempty),
  Semigroup ((<>)),
  Text,
  catch,
  liftIO,
  not,
  show,
  throwError,
  throwIO,
  when,
  ($),
  (&),
  (.),
  (/=),
  (<&>),
 )
import Protolude qualified as P

import Control.Monad.Catch (catchAll)
import Data.Aeson (KeyValue ((.=)), Value (String), encode, object)
import Data.ByteString qualified as BS
import Data.ByteString.Builder (toLazyByteString)
import Data.ByteString.Lazy qualified as BL
import Data.Either.Extra (mapLeft)
import Data.List qualified as List
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Database.SQLite.Simple (Connection)
import Database.SQLite.Simple qualified as SS
import Network.HTTP.Types (HeaderName, encodePathSegments)
import Servant.Server (
  ServerError (errBody, errHeaders),
  err400,
  err404,
  err500,
 )
import Servant.Server qualified as Servant
import System.Directory (removeFile)
import System.FilePath (takeFileName, (</>))
import System.IO.Error (IOError, isDoesNotExistError)
import System.Posix.Files (readSymbolicLink)
import System.Process (readProcess)
import System.Process.Typed (
  byteStringInput,
  createPipe,
  proc,
  readProcessInterleaved,
  setStderr,
  setStdin,
  setStdout,
 )

import AirGQL.ExternalAppContext (ExternalAppContext (sqlite))


getDbDir :: Text -> FilePath
getDbDir :: Text -> FilePath
getDbDir Text
dbId =
  FilePath
"data"
    FilePath -> FilePath -> FilePath
</> FilePath
"databases"
    FilePath -> FilePath -> FilePath
</> Text -> FilePath
T.unpack Text
dbId


getMainDbPath :: Text -> FilePath
getMainDbPath :: Text -> FilePath
getMainDbPath Text
dbId =
  Text -> FilePath
getDbDir Text
dbId
    FilePath -> FilePath -> FilePath
</> FilePath
"main.sqlite"


getReadOnlyFilePath :: Text -> FilePath
getReadOnlyFilePath :: Text -> FilePath
getReadOnlyFilePath Text
readonlyId =
  FilePath
"data" FilePath -> FilePath -> FilePath
</> FilePath
"readonly" FilePath -> FilePath -> FilePath
</> Text -> FilePath
T.unpack Text
readonlyId


getSqliteEmbeddedVersion :: Connection -> IO Text
getSqliteEmbeddedVersion :: Connection -> IO Text
getSqliteEmbeddedVersion Connection
conn = do
  [[SQLData]]
sqliteEmbeddedVersion <-
    Connection -> Query -> IO [[SQLData]]
forall r. FromRow r => Connection -> Query -> IO [r]
SS.query_
      Connection
conn
      Query
"select sqlite_version()"
      :: IO [[SS.SQLData]]
  case [[SQLData]]
sqliteEmbeddedVersion of
    [[SS.SQLText Text
verTxt]] -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
verTxt
    [[SQLData]]
_ -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
forall a. Monoid a => a
mempty


getSqliteBinaryVersion :: ExternalAppContext -> IO Text
getSqliteBinaryVersion :: ExternalAppContext -> IO Text
getSqliteBinaryVersion ExternalAppContext
ctx = do
  (FilePath -> Text) -> IO FilePath -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (Text -> Text
T.strip (Text -> Text) -> (FilePath -> Text) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack) (IO FilePath -> IO Text) -> IO FilePath -> IO Text
forall a b. (a -> b) -> a -> b
$
    FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess
      ExternalAppContext
ctx.sqlite
      [FilePath
"--safe", FilePath
":memory:"]
      (Text -> FilePath
T.unpack Text
"select sqlite_version()")


getGraphiQLVersion :: IO Text
getGraphiQLVersion :: IO Text
getGraphiQLVersion = do
  -- let packageJson :: BL.ByteString =
  --       $( "package.json"
  --           & makeRelativeToProject
  --           P.>>= embedStringFile
  --        )
  --
  -- pure $
  --   (Aeson.decode packageJson :: Maybe Object)
  --     P.>>= KeyMap.lookup "dependencies"
  --     P.>>= ( \case
  --               Aeson.Object o -> KeyMap.lookup "graphiql" o
  --               _ -> Nothing
  --           )
  --     P.>>= ( \case
  --               Aeson.String s -> Just s
  --               _ -> Nothing
  --           )
  --     & fromMaybe ""
  Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"TODO"


-- | Escape double quotes in SQL strings
escDoubleQuotes :: Text -> Text
escDoubleQuotes :: Text -> Text
escDoubleQuotes =
  HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\"" Text
"\"\""


-- | Quote a keyword in an SQL query
quoteKeyword :: Text -> Text
quoteKeyword :: Text -> Text
quoteKeyword Text
keyword =
  Text
keyword
    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> Text
escDoubleQuotes
    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& (\Text
word -> Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
word Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"")


-- | Escape single quotes in SQL strings
escSingleQuotes :: Text -> Text
escSingleQuotes :: Text -> Text
escSingleQuotes =
  HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"'" Text
"''"


-- | Quote literal text in an SQL query
quoteText :: Text -> Text
quoteText :: Text -> Text
quoteText Text
keyword =
  Text
keyword
    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> Text
escSingleQuotes
    Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& (\Text
word -> Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
word Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'")


headerJsonContent :: [(HeaderName, BS.ByteString)]
headerJsonContent :: [(HeaderName, ByteString)]
headerJsonContent =
  [(HeaderName
"Content-Type", ByteString
"application/json;charset=utf-8")]


-- | Throw the specified server error with a message
throwServerErrorWithMsg :: ServerError -> Text -> Servant.Handler a
throwServerErrorWithMsg :: forall a. ServerError -> Text -> Handler a
throwServerErrorWithMsg ServerError
serverError Text
errorMsg =
  ServerError -> Handler a
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ServerError -> Handler a) -> ServerError -> Handler a
forall a b. (a -> b) -> a -> b
$
    ServerError
serverError
      { errHeaders = headerJsonContent
      , errBody =
          encode $
            object
              ["errors" .= [String errorMsg]]
      }


-- | Throw an "400 Bad Request" error with a message
throwErr400WithMsg :: Text -> Servant.Handler a
throwErr400WithMsg :: forall a. Text -> Handler a
throwErr400WithMsg = ServerError -> Text -> Handler a
forall a. ServerError -> Text -> Handler a
throwServerErrorWithMsg ServerError
err400


-- | Throw an "404 Not Found" error with a message
throwErr404WithMsg :: Text -> Servant.Handler a
throwErr404WithMsg :: forall a. Text -> Handler a
throwErr404WithMsg = ServerError -> Text -> Handler a
forall a. ServerError -> Text -> Handler a
throwServerErrorWithMsg ServerError
err404


-- | Throw an "500 Internal Server Error" error with a message
throwErr500WithMsg :: Text -> Servant.Handler a
throwErr500WithMsg :: forall a. Text -> Handler a
throwErr500WithMsg = ServerError -> Text -> Handler a
forall a. ServerError -> Text -> Handler a
throwServerErrorWithMsg ServerError
err500


{-| Get the order of a linked list.
 | Each tuple is `(name, previous name in list)`.
 | The first's element previous name is `Nothing`.
 | Tries to find the longest chain of elements if no start element is found.
 | It's quite complicated to also handle incomplete orderings correctly.
-}
getOrderOfLinkedList :: [(Text, Maybe Text)] -> [Text]
getOrderOfLinkedList :: [(Text, Maybe Text)] -> [Text]
getOrderOfLinkedList [(Text, Maybe Text)]
tables =
  let
    findAfter :: [(Text, Maybe Text)] -> (Text, Maybe Text) -> [Text]
    findAfter :: [(Text, Maybe Text)] -> (Text, Maybe Text) -> [Text]
findAfter [(Text, Maybe Text)]
remaining (Text
tableName, Maybe Text
previousTableMb) =
      Maybe Text -> [Text]
forall a. Maybe a -> [a]
P.maybeToList Maybe Text
previousTableMb
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> case ((Text, Maybe Text) -> Bool)
-> [(Text, Maybe Text)] -> Maybe (Text, Maybe Text)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
P.find ((Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
P.== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
tableName) (Maybe Text -> Bool)
-> ((Text, Maybe Text) -> Maybe Text) -> (Text, Maybe Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
P.. (Text, Maybe Text) -> Maybe Text
forall a b. (a, b) -> b
P.snd) [(Text, Maybe Text)]
remaining of
          Just found :: (Text, Maybe Text)
found@(Text
name, Maybe Text
_) ->
            let remaining' :: [(Text, Maybe Text)]
remaining' = ((Text, Maybe Text) -> Bool)
-> [(Text, Maybe Text)] -> [(Text, Maybe Text)]
forall a. (a -> Bool) -> [a] -> [a]
List.filter ((Text, Maybe Text) -> (Text, Maybe Text) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Text, Maybe Text)
found) [(Text, Maybe Text)]
remaining
            in  Text
tableName Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [(Text, Maybe Text)] -> (Text, Maybe Text) -> [Text]
findAfter [(Text, Maybe Text)]
remaining' (Text
name, Maybe Text
forall a. Maybe a
Nothing)
          Maybe (Text, Maybe Text)
Nothing -> [Text
tableName]
  in
    if [(Text, Maybe Text)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
P.null [(Text, Maybe Text)]
tables
      then []
      else
        let
          sortByLength :: [[Text]] -> [[Text]]
          sortByLength :: [[Text]] -> [[Text]]
sortByLength =
            ([Text] -> [Text] -> Ordering) -> [[Text]] -> [[Text]]
forall a. (a -> a -> Ordering) -> [a] -> [a]
P.sortBy (\[Text]
x [Text]
y -> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
P.compare ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
P.length [Text]
y) ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
P.length [Text]
x))

          chainsByLength :: [[Text]]
chainsByLength =
            [(Text, Maybe Text)]
tables
              [(Text, Maybe Text)] -> ((Text, Maybe Text) -> [Text]) -> [[Text]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [(Text, Maybe Text)] -> (Text, Maybe Text) -> [Text]
findAfter [(Text, Maybe Text)]
tables
              [[Text]] -> ([[Text]] -> [[Text]]) -> [[Text]]
forall a b. a -> (a -> b) -> b
& [[Text]] -> [[Text]]
sortByLength

          -- First table ist always the (x, Nothing) table entry
          firstElement :: [Text]
firstElement =
            case ((Text, Maybe Text) -> Bool)
-> [(Text, Maybe Text)] -> Maybe (Text, Maybe Text)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
P.find ((Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
P.== Maybe Text
forall a. Maybe a
Nothing) (Maybe Text -> Bool)
-> ((Text, Maybe Text) -> Maybe Text) -> (Text, Maybe Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
P.. (Text, Maybe Text) -> Maybe Text
forall a b. (a, b) -> b
P.snd) [(Text, Maybe Text)]
tables of
              Just (Text, Maybe Text)
tableEntry -> [(Text, Maybe Text) -> Text
forall a b. (a, b) -> a
P.fst (Text, Maybe Text)
tableEntry]
              Maybe (Text, Maybe Text)
Nothing -> []
        in
          -- Sort them by length, combine them, and remove duplicates
          ([[Text]
firstElement] [[Text]] -> [[Text]] -> [[Text]]
forall a. Semigroup a => a -> a -> a
<> [[Text]]
chainsByLength)
            [[Text]] -> ([[Text]] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
P.concat
            [Text] -> ([Text] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& [Text] -> [Text]
forall a. Eq a => [a] -> [a]
List.nub


getDbIdFromReadOnlyId :: Text -> IO (Maybe Text)
getDbIdFromReadOnlyId :: Text -> IO (Maybe Text)
getDbIdFromReadOnlyId Text
readOnlyId = do
  IO (Maybe Text)
-> (SomeException -> IO (Maybe Text)) -> IO (Maybe Text)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
catchAll
    ( do
        FilePath
dbId <- IO FilePath -> IO FilePath
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
readSymbolicLink (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
getReadOnlyFilePath Text
readOnlyId
        Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeFileName FilePath
dbId
    )
    ( \SomeException
err -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FilePath
"does not exist" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`P.isInfixOf` SomeException -> FilePath
forall a b. (Show a, StringConv FilePath b) => a -> b
show SomeException
err) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
P.putErrText (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Error while reading readonly symlink:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall a b. (Show a, StringConv FilePath b) => a -> b
show SomeException
err
        Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
    )


colToFileUrl :: Text -> Text -> Text -> Text -> Text
colToFileUrl :: Text -> Text -> Text -> Text -> Text
colToFileUrl Text
readonlyId Text
tableName Text
colName Text
rowid =
  ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$
    ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
      Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
        [Text] -> Builder
encodePathSegments
          [ Text
"readonly"
          , Text
readonlyId
          , Text
"tables"
          , Text
tableName
          , Text
"columns"
          , Text
colName
          , Text
"files"
          , Text
"rowid"
          , Text
rowid
          ]


removeIfExists :: FilePath -> IO ()
removeIfExists :: FilePath -> IO ()
removeIfExists FilePath
fileName =
  let
    handleExists :: IOError -> IO ()
    handleExists :: IOError -> IO ()
handleExists IOError
e
      | IOError -> Bool
isDoesNotExistError IOError
e = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
P.otherwise = IOError -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO IOError
e
  in
    FilePath -> IO ()
removeFile FilePath
fileName IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOError -> IO ()
handleExists


runSqliteCommand :: ExternalAppContext -> FilePath -> BL.ByteString -> Servant.Handler Text
runSqliteCommand :: ExternalAppContext -> FilePath -> ByteString -> Handler Text
runSqliteCommand ExternalAppContext
ctx FilePath
dbPath ByteString
command = do
  let
    processConfig :: ProcessConfig () Handle Handle
processConfig =
      StreamSpec 'STInput ()
-> ProcessConfig () Handle Handle -> ProcessConfig () Handle Handle
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin
        (ByteString -> StreamSpec 'STInput ()
byteStringInput ByteString
command)
        (ProcessConfig () Handle Handle -> ProcessConfig () Handle Handle)
-> ProcessConfig () Handle Handle -> ProcessConfig () Handle Handle
forall a b. (a -> b) -> a -> b
$ StreamSpec 'STOutput Handle
-> ProcessConfig () () Handle -> ProcessConfig () Handle Handle
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout StreamSpec 'STOutput Handle
forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
createPipe
        (ProcessConfig () () Handle -> ProcessConfig () Handle Handle)
-> ProcessConfig () () Handle -> ProcessConfig () Handle Handle
forall a b. (a -> b) -> a -> b
$ StreamSpec 'STOutput Handle
-> ProcessConfig () () () -> ProcessConfig () () Handle
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr StreamSpec 'STOutput Handle
forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
createPipe
        (ProcessConfig () () () -> ProcessConfig () () Handle)
-> ProcessConfig () () () -> ProcessConfig () () Handle
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> ProcessConfig () () ()
proc ExternalAppContext
ctx.sqlite [FilePath
dbPath]

  (ExitCode
exitCode, ByteString
output) <- ProcessConfig () Handle Handle -> Handler (ExitCode, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ExitCode, ByteString)
readProcessInterleaved ProcessConfig () Handle Handle
processConfig

  let outputText :: Text
outputText = ByteString -> Text
P.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.toStrict ByteString
output

  case ExitCode
exitCode of
    ExitCode
ExitSuccess ->
      Text -> Handler Text
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
outputText
    ExitFailure Int
_ ->
      Text -> Handler Text
forall a. Text -> Handler a
throwErr500WithMsg Text
outputText


-- | Similar to `sequence`, except it doesn't stop on the first error.
collectErrorList :: [P.Either e b] -> P.Either [e] [b]
collectErrorList :: forall e b. [Either e b] -> Either [e] [b]
collectErrorList [Either e b]
results =
  case [Either e b] -> [e]
forall a b. [Either a b] -> [a]
P.lefts [Either e b]
results of
    [] -> [b] -> Either [e] [b]
forall a b. b -> Either a b
P.Right ([Either e b] -> [b]
forall a b. [Either a b] -> [b]
P.rights [Either e b]
results)
    [e]
lefts -> [e] -> Either [e] [b]
forall a b. a -> Either a b
P.Left [e]
lefts


{-|
Similar to `sequence`, except it doesn't stop on the first error.
What differentiates this from `collectErrorList` is
that it also merges the errors into a single error message.
-}
collectAllErrorsAsText :: [P.Either Text b] -> P.Either Text [b]
collectAllErrorsAsText :: forall b. [Either Text b] -> Either Text [b]
collectAllErrorsAsText [Either Text b]
results =
  [Either Text b] -> Either [Text] [b]
forall e b. [Either e b] -> Either [e] [b]
collectErrorList [Either Text b]
results
    Either [Text] [b]
-> (Either [Text] [b] -> Either Text [b]) -> Either Text [b]
forall a b. a -> (a -> b) -> b
& ([Text] -> Text) -> Either [Text] [b] -> Either Text [b]
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft
      ( \[Text]
lefts ->
          Text
"Multiple errors occurred:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
P.unlines [Text]
lefts
      )


data DiffKind = Added | Removed | Kept
  deriving (DiffKind -> DiffKind -> Bool
(DiffKind -> DiffKind -> Bool)
-> (DiffKind -> DiffKind -> Bool) -> Eq DiffKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DiffKind -> DiffKind -> Bool
== :: DiffKind -> DiffKind -> Bool
$c/= :: DiffKind -> DiffKind -> Bool
/= :: DiffKind -> DiffKind -> Bool
P.Eq, Eq DiffKind
Eq DiffKind =>
(DiffKind -> DiffKind -> Ordering)
-> (DiffKind -> DiffKind -> Bool)
-> (DiffKind -> DiffKind -> Bool)
-> (DiffKind -> DiffKind -> Bool)
-> (DiffKind -> DiffKind -> Bool)
-> (DiffKind -> DiffKind -> DiffKind)
-> (DiffKind -> DiffKind -> DiffKind)
-> Ord DiffKind
DiffKind -> DiffKind -> Bool
DiffKind -> DiffKind -> Ordering
DiffKind -> DiffKind -> DiffKind
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
$ccompare :: DiffKind -> DiffKind -> Ordering
compare :: DiffKind -> DiffKind -> Ordering
$c< :: DiffKind -> DiffKind -> Bool
< :: DiffKind -> DiffKind -> Bool
$c<= :: DiffKind -> DiffKind -> Bool
<= :: DiffKind -> DiffKind -> Bool
$c> :: DiffKind -> DiffKind -> Bool
> :: DiffKind -> DiffKind -> Bool
$c>= :: DiffKind -> DiffKind -> Bool
>= :: DiffKind -> DiffKind -> Bool
$cmax :: DiffKind -> DiffKind -> DiffKind
max :: DiffKind -> DiffKind -> DiffKind
$cmin :: DiffKind -> DiffKind -> DiffKind
min :: DiffKind -> DiffKind -> DiffKind
P.Ord, Int -> DiffKind -> FilePath -> FilePath
[DiffKind] -> FilePath -> FilePath
DiffKind -> FilePath
(Int -> DiffKind -> FilePath -> FilePath)
-> (DiffKind -> FilePath)
-> ([DiffKind] -> FilePath -> FilePath)
-> Show DiffKind
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> DiffKind -> FilePath -> FilePath
showsPrec :: Int -> DiffKind -> FilePath -> FilePath
$cshow :: DiffKind -> FilePath
show :: DiffKind -> FilePath
$cshowList :: [DiffKind] -> FilePath -> FilePath
showList :: [DiffKind] -> FilePath -> FilePath
P.Show)


{-| Run an action with a connection, retrying if the database is busy.
| Necessary because of WAL mode:
| https://sqlite.org/wal.html#sometimes_queries_return_sqlite_busy_in_wal_mode
-}
withRetryConn :: FilePath -> (Connection -> IO a) -> IO a
withRetryConn :: forall a. FilePath -> (Connection -> IO a) -> IO a
withRetryConn FilePath
filePath Connection -> IO a
action = do
  FilePath -> (Connection -> IO a) -> IO a
forall a. FilePath -> (Connection -> IO a) -> IO a
SS.withConnection FilePath
filePath ((Connection -> IO a) -> IO a) -> (Connection -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
    Connection -> Query -> IO ()
SS.execute_ Connection
conn Query
"PRAGMA busy_timeout = 5000;" -- 5 seconds
    Connection -> IO a
action Connection
conn