diff options
Diffstat (limited to 'backend/app')
| -rw-r--r-- | backend/app/Main.hs | 510 |
1 files changed, 0 insertions, 510 deletions
diff --git a/backend/app/Main.hs b/backend/app/Main.hs deleted file mode 100644 index c9db2ea..0000000 --- a/backend/app/Main.hs +++ /dev/null @@ -1,510 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - -module Main where - -import AutoTypes qualified as U -import AutoTypes.Unify qualified as U -import Control.Applicative ((<**>)) -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception (throwIO) -import Control.Monad -import Control.Monad.Catch -import Control.Monad.Trans (liftIO) -import Data.Aeson qualified as J -import Data.Aeson.Key qualified as JK -import Data.Aeson.KeyMap qualified as JM -import Data.Bifunctor -import Data.ByteString.Lazy.UTF8 qualified as LB -import Data.ByteString.UTF8 qualified as B -import Data.Function (on, (&)) -import Data.List -import Data.Map qualified as M -import Data.Map.Merge.Strict qualified as M -import Data.Maybe -import Data.Set qualified as S -import Data.String (IsString (fromString)) -import Data.Tagged (Tagged (..), untag) -import Data.Text qualified as T -import Data.UUID qualified as U -import Data.UUID.V4 qualified as U -import Data.Vector qualified as V -import Git qualified as G -import Git.Libgit2 qualified as GB -import Network.HTTP.Types.Status qualified as W -import Network.Wai qualified as W -import Network.Wai.Handler.Warp qualified as W -import Options.Applicative qualified as A -import Safe -import Store qualified as Q -import System.Directory (doesDirectoryExist, makeAbsolute, setCurrentDirectory) -import System.Environment -import System.Exit -import System.FilePath -import System.INotify -import System.IO qualified as IO -import System.Random -import Text.Printf (printf) -import Version - -getUUID :: IO U.UUID -getUUID = maybe U.nextRandom (const randomIO) =<< lookupEnv "UUID_SEED" - -data Args = Args - { cmd :: Cmd - } - -args :: A.Parser Args -args = Args <$> cmd' - -data Cmd = Serve - { serverPort :: Int, - contentRepositoryPath :: FilePath - } - -cmd' :: A.Parser Cmd -cmd' = - A.hsubparser . mconcat $ - [ A.command "serve" . A.info serveCmd $ - A.progDesc "Run webserver" - ] - -serveCmd :: A.Parser Cmd -serveCmd = do - serverPort <- A.option A.auto (A.metavar "PORT" <> A.showDefault <> A.value 8081 <> A.long "port" <> A.short 'p' <> A.help "The server port") - contentRepositoryPath <- A.strArgument (A.metavar "PATH" <> A.help "Path to the content repository") - pure Serve {..} - -data Repo = Repo - { commits :: [Commit] - } - deriving (Show) - -data Commit = Commit - { id :: G.CommitOid GB.LgRepo, - collections :: [Collection], - schemaVersion :: Version, - refMap :: RefMap - } - deriving (Show) - -sameCommit :: Commit -> Commit -> Bool -sameCommit = (==) `on` (G.renderOid . untag . (.id)) - -data Collection = Collection - { path :: FilePath, - files :: [FilePath], - schema :: U.T - } - deriving (Show) - -data Schema = Schema {unSchema :: J.Value} - deriving (Show) - -instance J.ToJSON Schema where - toJSON = J.toJSON . (.unSchema) - -fromAutoTypes :: String -> U.T -> Schema -fromAutoTypes path (U.Object ps) = - Schema $ - J.object - [ ("$schema", J.toJSON @String "https://json-schema.org/draft/2020-12/schema"), - ("$id", J.toJSON @String (path <> ".schema.json")), - ("title", J.toJSON @String path), - ("type", J.toJSON @String "object"), - ("properties", J.toJSON ps), - ("required", J.toJSON (M.keys (M.filter isRequired ps))) - ] - where - isRequired (U.Option _) = False - isRequired _ = True -fromAutoTypes _ _ = error "Only JSON objects are supported." - -watch :: TMVar Repo -> FilePath -> G.RefName -> IO () -watch repoT root ref = do - i <- initINotify - qT <- newTQueueIO - _ <- - addWatch i [Create, MoveIn] ".git/refs/heads" $ \e -> do - when (e.filePath == B.fromString (takeBaseName (T.unpack ref))) do - atomically (writeTQueue qT e) - repo <- initRepo root ref - atomically do putTMVar repoT repo - forever do - _ <- atomically do - let loop = maybe (pure ()) (const loop) =<< tryReadTQueue qT - readTQueue qT >> loop - repo' <- atomically do takeTMVar repoT - catches - ( do - repo <- initRepo root ref - atomically do putTMVar repoT repo - ) - [ Handler - ( \(e :: ReferenceViolation) -> do - atomically do putTMVar repoT repo' - throwIO e - ), - Handler - ( \(e :: SomeException) -> do - printf "debug: %s\n" (displayException e) - atomically do putTMVar repoT repo' - ) - ] - pure () - -initRepo :: FilePath -> G.RefName -> IO Repo -initRepo root ref = do - repo <- G.openRepository GB.lgFactory G.defaultRepositoryOptions {G.repoPath = root} - G.runRepository GB.lgFactory repo do - Just cid <- fmap Tagged <$> G.resolveReference ref - cs <- mapM G.lookupCommit =<< G.listCommits Nothing cid - fmap (Repo . reverse) $ - foldM - ( \cs c -> do - let cid = G.commitOid c - fs <- liftIO $ Q.withStore root ref do - Q.withCommit cid (Q.listFiles "/") - let cls = - M.toList . M.unionsWith (++) $ - map (\f -> M.singleton (takeDirectory f) [f]) fs - colls <- forM cls $ \(path, files) -> do - J.Array (V.toList -> (value : values)) <- do - liftIO . Q.withStore root ref . Q.withCommit cid $ do - Q.query (fromString ("SELECT " <> path <> " FROM " <> path)) - let schema = - U.autoTypes' - (fileNameToId value) - (fileNameToId <$> values) - pure $ Collection path files schema - refMap <- liftIO . Q.withStore root ref . Q.withCommit cid $ do - buildRefMap - let schemaVersion = - case headMay cs of - Nothing -> Version 1 0 0 - Just c' -> - let Version major' minor' patch' = c'.schemaVersion - schemas' = - M.fromList - ( (\coll -> (coll.path, coll.schema)) - <$> c'.collections - ) - schemas = - M.fromList - ( (\coll -> (coll.path, coll.schema)) - <$> c.collections - ) - in case compareSchemas schemas' schemas of - Just Major -> Version (major' + 1) 0 0 - Just Minor -> Version major' (minor' + 1) 0 - Just Patch -> Version major' minor' (patch' + 1) - Nothing -> Version major' minor' patch' - c = Commit cid colls schemaVersion refMap - pure (c : cs) - ) - [] - cs - -compareSchemas :: - M.Map String U.T -> - M.Map String U.T -> - Maybe SchemaDifference -compareSchemas schemas' schemas = - maximumMay - . catMaybes - . M.elems - . M.map (uncurry compareSchemas') - $ M.merge - (M.mapMissing (\_ schema' -> (Just schema', Nothing))) - (M.mapMissing (\_ schema -> (Nothing, Just schema))) - (M.zipWithMatched (\_ schema' schema -> (Just schema', Just schema))) - schemas' - schemas - where - compareSchemas' Nothing Nothing = Nothing - compareSchemas' Nothing (Just _) = Just Minor - compareSchemas' (Just _) Nothing = Just Major - compareSchemas' (Just schema') (Just schema) = compareSchema schema' schema - -compareSchema :: U.T -> U.T -> Maybe SchemaDifference -compareSchema (U.Object kts') (U.Object kts) = compareSchemas kts' kts -compareSchema t' t - | t' == t = Nothing - | t' `elem` (U.unify1 t' t) = Just Patch - | t `elem` U.unify1 t' t = Just Minor - | otherwise = Just Major - -data SchemaDifference - = Major - | Minor - | Patch - deriving (Show, Eq, Ord) - -logStderr :: String -> IO () -logStderr = IO.hPutStrLn IO.stderr - -data RefMap = RefMap - { references :: M.Map FilePath (S.Set FilePath), - referencees :: M.Map FilePath (S.Set FilePath) - } - deriving (Show) - -data ReferenceViolation - = ReferenceViolation - { referencee :: FilePath, - referencees :: S.Set FilePath - } - deriving (Show) - -instance Exception ReferenceViolation - -buildRefMap :: Q.StoreM RefMap -buildRefMap = do - allIds <- - S.fromList - . map ((,) <$> takeDirectory <*> (dropExtension . takeBaseName)) - <$> Q.listFiles "" - refMap <- - foldl' - ( \refMap (referencee, reference) -> - RefMap - { references = M.insertWith S.union referencee (S.singleton reference) refMap.references, - referencees = M.insertWith S.union reference (S.singleton referencee) refMap.referencees - } - ) - (RefMap M.empty M.empty) - . concat - <$> mapM - ( \(c, i) -> do - v@(J.Object _) <- head <$> Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE (T.pack i)))) - pure (map (c </> i,) (collectReferences v)) - ) - (S.toList allIds) - checkRefMap allIds refMap - pure refMap - where - collectReferences (J.Object kvs) = - case map (first JK.toString) (JM.toList kvs) of - [("$ref", J.String i)] -> [T.unpack i] - _ -> concat (JM.elems (JM.map collectReferences kvs)) - collectReferences (J.Array vs) = concatMap collectReferences vs - collectReferences _ = [] - - checkRefMap allIds (RefMap {referencees}) = do - mapM_ - ( \(reference, referencees) -> - when (not (reference `S.member` S.map (uncurry (</>)) allIds)) do - liftIO (throwIO (ReferenceViolation reference referencees)) - ) - (M.toList referencees) - -main :: IO () -main = do - uuidSeed <- lookupEnv "UUID_SEED" - maybe (pure ()) (setStdGen . mkStdGen) $ readMay =<< uuidSeed - - A.execParser (A.info (args <**> A.helper) A.idm) >>= \case - Args {cmd = Serve {contentRepositoryPath, serverPort}} -> do - contentRepositoryPath' <- makeAbsolute contentRepositoryPath - contentRepositoryPathExists <- doesDirectoryExist (contentRepositoryPath' </> ".git") - - unless contentRepositoryPathExists $ do - logStderr $ "Content repository '" ++ contentRepositoryPath ++ "' is not a git repository." - exitFailure - - setCurrentDirectory contentRepositoryPath' - - let root = "." - ref = "refs/heads/master" - repoT <- newEmptyTMVarIO - - stopM <- newEmptyMVar - flip forkFinally (putMVar stopM) do watch repoT root ref - mapM - ( \hostPref -> flip forkFinally (putMVar stopM) do - W.runSettings - ( W.defaultSettings - & W.setPort serverPort - & W.setHost hostPref - ) - . restApi root ref repoT - . queryApi root ref repoT - $ (\_ resp -> resp (W.responseLBS W.status404 [] "Not found")) - ) - ["!4", "::1"] -- XXX note !6 does not work.. - logStderr ("Serving " ++ contentRepositoryPath' ++ " on port " ++ show serverPort ++ ".") - either throwIO pure =<< takeMVar stopM - -data InvalidSchemaVersion = InvalidSchemaVersion String - deriving (Show) - -instance Exception InvalidSchemaVersion - -queryApi :: FilePath -> T.Text -> TMVar Repo -> W.Middleware -queryApi root ref repoT app req resp = do - schemaVersion <- - case find ((== "schemaVersion") . fst) (W.queryString req) of - Nothing -> pure Nothing - Just (_, Nothing) -> throwIO (InvalidSchemaVersion "") - Just (_, Just (B.toString -> v)) -> - case versionFromString v of - Just v -> pure (Just v) - Nothing -> throwIO (InvalidSchemaVersion v) - repo <- atomically (readTMVar repoT) - let lastCompatibleCommit = lastCompatible schemaVersion repo.commits - lastCommit = last repo.commits - case W.pathInfo req of - ["api", "query"] -> - case W.requestMethod req of - "POST" -> do - when (not (sameCommit lastCompatibleCommit lastCommit)) $ - error "not implemented" - q <- fromString @Q.Query . LB.toString <$> W.lazyRequestBody req - resp . W.responseLBS W.status200 [] . J.encode . fileNameToId - =<< Q.withStore root ref do Q.query @J.Value q - _ -> do - error "not implemented" - _ -> app req resp - -restApi :: FilePath -> T.Text -> TMVar Repo -> W.Middleware -restApi root ref repoT app req resp = do - schemaVersion <- - case find ((== "schemaVersion") . fst) (W.queryString req) of - Nothing -> pure Nothing - Just (_, Nothing) -> throwIO (InvalidSchemaVersion "") - Just (_, Just (B.toString -> v)) -> - case versionFromString v of - Just v -> pure (Just v) - Nothing -> throwIO (InvalidSchemaVersion v) - repo <- atomically (readTMVar repoT) - let lastCompatibleCommit = lastCompatible schemaVersion repo.commits - rev = lastCompatibleCommit.id - lastCommit = last repo.commits - case W.pathInfo req of - ("api" : "rest" : rs) -> - case (W.requestMethod req, rs) of - ("GET", ["schemaVersion"]) -> do - resp . W.responseLBS W.status200 [] $ - J.encode lastCompatibleCommit.schemaVersion - ("GET", ["collection"]) -> do - resp . W.responseLBS W.status200 [] $ - J.encode (map (.path) lastCompatibleCommit.collections) - ("GET", ["collection", T.unpack -> c, "schema"]) -> do - case find ((== c) . (.path)) lastCompatibleCommit.collections of - Nothing -> error "not implemented" - Just collection -> - resp . W.responseLBS W.status200 [] $ - J.encode (fromAutoTypes c collection.schema) - ("POST", ["collection"]) -> do - when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" - Right collection <- J.eitherDecode <$> W.lazyRequestBody req - Q.withStore root ref do - Q.writeFile (collection </> ".gitkeep") "" - Q.commit - resp $ W.responseLBS W.status200 [] "{}" - ("GET", ["collection", c]) -> do - resp . W.responseLBS W.status200 [] . J.encode . fileNameToId - =<< ( Q.withStore root ref $ Q.withCommit rev do - Q.query @J.Value (fromString (printf "SELECT %s FROM %s" c c)) - ) - ("GET", ["collection", c, "paginated", read @Int . T.unpack -> limit, read @Int . T.unpack -> offset]) -> do - resp . W.responseLBS W.status200 [] . J.encode . fileNameToId - =<< ( Q.withStore root ref $ Q.withCommit rev do - Q.query @J.Value - ( fromString - ( printf - "SELECT %s FROM %s%s%s" - c - c - (printf " LIMIT %d" limit :: String) - (printf " OFFSET %d" offset :: String) - ) - ) - ) - ("GET", ["collection", c, i]) -> do - resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head - =<< ( Q.withStore root ref $ Q.withCommit rev do - Q.query @[J.Value] (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i))) - ) - ("PUT", ["collection", c, i]) -> do - when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" - o <- J.throwDecode @J.Object =<< W.lazyRequestBody req - resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head - =<< ( Q.withStore root ref do - _ <- Q.query @J.Value (fromString (printf "UPDATE %s SET %s WHERE %s.$fileName =~ /^%s\\.json$/" c (LB.toString (J.encode o)) c (escapePCRE i))) - J.Array (V.toList -> [J.Object r]) <- Q.query @J.Value (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i))) - _ <- Q.query @J.Value (fromString (printf "INSERT %s INTO %s" (LB.toString (J.encode (dropNulls r))) c)) - _ <- buildRefMap - Q.query @[J.Value] (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i))) - ) - ("POST", ["collection", c]) -> do - when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" - i <- U.toText <$> getUUID - o <- fmap dropNulls . J.throwDecode @J.Object =<< W.lazyRequestBody req - resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head - =<< ( Q.withStore root ref do - _ <- Q.query @J.Value (fromString (printf "INSERT %s INTO %s" (LB.toString (J.encode (JM.insert "$fileName" (J.String (i <> ".json")) o))) c)) - _ <- buildRefMap - Q.query @[J.Value] (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i))) - ) - ("DELETE", ["collection", c, i]) -> do - when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" - resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head - =<< ( Q.withStore root ref do - r <- Q.query @[J.Value] (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i))) - Q.query @J.Value (fromString (printf "DELETE FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c (escapePCRE i))) - _ <- buildRefMap - pure r - ) - (method, path) -> fail $ "Method " ++ show method ++ " on route " ++ show path ++ " not supported." - _ -> app req resp - -lastCompatible :: Maybe Version -> [Commit] -> Commit -lastCompatible Nothing commits = last commits -lastCompatible (Just v) commits - | isCompatible v (last commits) = last commits - | otherwise = lastCompatible (Just v) (init commits) - -isCompatible :: Version -> Commit -> Bool -isCompatible v c = c.schemaVersion <= v - -dropNulls :: J.Object -> J.Object -dropNulls = - JM.mapMaybe - ( \v -> - case v of - J.Null -> Nothing - (J.Object v') -> Just (J.Object (dropNulls v')) - _ -> Just v - ) - -escapePCRE :: T.Text -> T.Text -escapePCRE = T.pack . escapePCRE' . T.unpack - -escapePCRE' :: String -> String -escapePCRE' [] = [] -escapePCRE' (c : cs) = - ((if c `elem` (".^$*+?()[{\\|" :: String) then ('\\' :) else id) [c]) - <> escapePCRE' cs - -fileNameToId :: J.Value -> J.Value -fileNameToId (J.Array xs) = J.Array (V.map fileNameToId xs) -fileNameToId (J.Object kvs) = - J.Object - ( JM.foldrWithKey - ( \k v -> - case (k, v) of - ("$fileName", J.String v) -> - JM.insert "$id" (J.String (T.pack (dropExtension (T.unpack v)))) - _ -> - JM.insert k (fileNameToId v) - ) - JM.empty - $ kvs - ) -fileNameToId v = v |