1
Fork 0
mirror of https://github.com/Airsequel/AirGQL.git synced 2025-07-11 09:24:55 +03:00
airgql/source/AirGQL/Utils.hs

362 lines
9.2 KiB
Haskell

-- 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 dbId =
"data"
</> "databases"
</> T.unpack dbId
getMainDbPath :: Text -> FilePath
getMainDbPath dbId =
getDbDir dbId
</> "main.sqlite"
getReadOnlyFilePath :: Text -> FilePath
getReadOnlyFilePath readonlyId =
"data" </> "readonly" </> T.unpack readonlyId
getSqliteEmbeddedVersion :: Connection -> IO Text
getSqliteEmbeddedVersion conn = do
sqliteEmbeddedVersion <-
SS.query_
conn
"select sqlite_version()"
:: IO [[SS.SQLData]]
case sqliteEmbeddedVersion of
[[SS.SQLText verTxt]] -> pure verTxt
_ -> pure mempty
getSqliteBinaryVersion :: ExternalAppContext -> IO Text
getSqliteBinaryVersion ctx = do
P.fmap (T.strip . T.pack) $
readProcess
ctx.sqlite
["--safe", ":memory:"]
(T.unpack "select sqlite_version()")
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 ""
pure "TODO"
-- | Escape double quotes in SQL strings
escDoubleQuotes :: Text -> Text
escDoubleQuotes =
T.replace "\"" "\"\""
-- | Quote a keyword in an SQL query
quoteKeyword :: Text -> Text
quoteKeyword keyword =
keyword
& escDoubleQuotes
& (\word -> "\"" <> word <> "\"")
-- | Escape single quotes in SQL strings
escSingleQuotes :: Text -> Text
escSingleQuotes =
T.replace "'" "''"
-- | Quote literal text in an SQL query
quoteText :: Text -> Text
quoteText keyword =
keyword
& escSingleQuotes
& (\word -> "'" <> word <> "'")
headerJsonContent :: [(HeaderName, BS.ByteString)]
headerJsonContent =
[("Content-Type", "application/json;charset=utf-8")]
-- | Throw the specified server error with a message
throwServerErrorWithMsg :: ServerError -> Text -> Servant.Handler a
throwServerErrorWithMsg serverError errorMsg =
throwError $
serverError
{ errHeaders = headerJsonContent
, errBody =
encode $
object
["errors" .= [String errorMsg]]
}
-- | Throw an "400 Bad Request" error with a message
throwErr400WithMsg :: Text -> Servant.Handler a
throwErr400WithMsg = throwServerErrorWithMsg err400
-- | Throw an "404 Not Found" error with a message
throwErr404WithMsg :: Text -> Servant.Handler a
throwErr404WithMsg = throwServerErrorWithMsg err404
-- | Throw an "500 Internal Server Error" error with a message
throwErr500WithMsg :: Text -> Servant.Handler a
throwErr500WithMsg = throwServerErrorWithMsg 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 tables =
let
findAfter :: [(Text, Maybe Text)] -> (Text, Maybe Text) -> [Text]
findAfter remaining (tableName, previousTableMb) =
P.maybeToList previousTableMb
<> case P.find ((P.== Just tableName) P.. P.snd) remaining of
Just found@(name, _) ->
let remaining' = List.filter (/= found) remaining
in tableName : findAfter remaining' (name, Nothing)
Nothing -> [tableName]
in
if P.null tables
then []
else
let
sortByLength :: [[Text]] -> [[Text]]
sortByLength =
P.sortBy (\x y -> P.compare (P.length y) (P.length x))
chainsByLength =
tables
<&> findAfter tables
& sortByLength
-- First table ist always the (x, Nothing) table entry
firstElement =
case P.find ((P.== Nothing) P.. P.snd) tables of
Just tableEntry -> [P.fst tableEntry]
Nothing -> []
in
-- Sort them by length, combine them, and remove duplicates
([firstElement] <> chainsByLength)
& P.concat
& List.nub
getDbIdFromReadOnlyId :: Text -> IO (Maybe Text)
getDbIdFromReadOnlyId readOnlyId = do
catchAll
( do
dbId <- liftIO $ readSymbolicLink $ getReadOnlyFilePath readOnlyId
pure $ Just $ T.pack $ takeFileName dbId
)
( \err -> do
when (not $ "does not exist" `P.isInfixOf` show err) $ do
P.putErrText $ "Error while reading readonly symlink:\n" <> show err
pure Nothing
)
colToFileUrl :: Text -> Text -> Text -> Text -> Text
colToFileUrl readonlyId tableName colName rowid =
T.decodeUtf8 $
BL.toStrict $
toLazyByteString $
encodePathSegments
[ "readonly"
, readonlyId
, "tables"
, tableName
, "columns"
, colName
, "files"
, "rowid"
, rowid
]
removeIfExists :: FilePath -> IO ()
removeIfExists fileName =
let
handleExists :: IOError -> IO ()
handleExists e
| isDoesNotExistError e = pure ()
| P.otherwise = throwIO e
in
removeFile fileName `catch` handleExists
runSqliteCommand :: ExternalAppContext -> FilePath -> BL.ByteString -> Servant.Handler Text
runSqliteCommand ctx dbPath command = do
let
processConfig =
setStdin
(byteStringInput command)
$ setStdout createPipe
$ setStderr createPipe
$ proc ctx.sqlite [dbPath]
(exitCode, output) <- readProcessInterleaved processConfig
let outputText = P.decodeUtf8 $ BS.toStrict output
case exitCode of
ExitSuccess ->
pure outputText
ExitFailure _ ->
throwErr500WithMsg outputText
-- | Similar to `sequence`, except it doesn't stop on the first error.
collectErrorList :: [P.Either e b] -> P.Either [e] [b]
collectErrorList results =
case P.lefts results of
[] -> P.Right (P.rights results)
lefts -> P.Left 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 results =
collectErrorList results
& mapLeft
( \lefts ->
"Multiple errors occurred:\n" <> P.unlines lefts
)
data DiffKind = Added | Removed | Kept
deriving (P.Eq, P.Ord, 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 filePath action = do
SS.withConnection filePath $ \conn -> do
SS.execute_ conn "PRAGMA busy_timeout = 5000;" -- 5 seconds
SS.execute_ conn "PRAGMA foreign_keys = True"
action conn