From 8d3fdb08672c89d8657dcd4475acfea56a66b906 Mon Sep 17 00:00:00 2001 From: Alexander Foremny Date: Fri, 31 May 2024 10:42:26 +0200 Subject: add frontend (boilerplate) --- LICENSE | 30 ----------- acms.cabal | 38 -------------- app/Main.hs | 132 ------------------------------------------------ backend/LICENSE | 30 +++++++++++ backend/app/Main.hs | 132 ++++++++++++++++++++++++++++++++++++++++++++++++ backend/backend.cabal | 38 ++++++++++++++ cabal.project | 2 +- default.nix | 28 ++++++++-- frontend/LICENSE | 30 +++++++++++ frontend/app/Main.hs | 77 ++++++++++++++++++++++++++++ frontend/frontend.cabal | 31 ++++++++++++ nix/sources.json | 6 +-- 12 files changed, 365 insertions(+), 209 deletions(-) delete mode 100644 LICENSE delete mode 100644 acms.cabal delete mode 100644 app/Main.hs create mode 100644 backend/LICENSE create mode 100644 backend/app/Main.hs create mode 100644 backend/backend.cabal create mode 100644 frontend/LICENSE create mode 100644 frontend/app/Main.hs create mode 100644 frontend/frontend.cabal diff --git a/LICENSE b/LICENSE deleted file mode 100644 index c90516a..0000000 --- a/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2024, Alexander Foremny - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Alexander Foremny nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/acms.cabal b/acms.cabal deleted file mode 100644 index 38a3bf2..0000000 --- a/acms.cabal +++ /dev/null @@ -1,38 +0,0 @@ -cabal-version: 3.4 -name: acms -version: 0.1.0.0 -license: BSD-3-Clause -license-file: LICENSE -maintainer: aforemny@posteo.de -author: Alexander Foremny -build-type: Simple - -executable acms - main-is: Main.hs - hs-source-dirs: app - default-language: GHC2021 - default-extensions: - BlockArguments LambdaCase OverloadedStrings ViewPatterns - OverloadedRecordDot NoFieldSelectors - - ghc-options: -Wall -threaded - build-depends: - aeson, - astore, - attoparsec, - autotypes, - base, - bytestring, - containers, - directory, - filepath, - gitlib, - gitlib-libgit2, - hlibgit2, - http-types, - mtl, - optparse-applicative, - tagged, - utf8-string, - wai, - warp diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 index fce12b4..0000000 --- a/app/Main.hs +++ /dev/null @@ -1,132 +0,0 @@ -module Main where - -import AutoTypes qualified as U -import AutoTypes.Unify qualified as U -import Control.Applicative ((<**>)) -import Control.Monad -import Control.Monad.Trans (liftIO) -import Data.Aeson qualified as J -import Data.Attoparsec.Char8 as P -import Data.ByteString.Char8 qualified as B -import Data.ByteString.Lazy.Char8 qualified as LB -import Data.ByteString.Lazy.UTF8 qualified as LB -import Data.ByteString.UTF8 qualified as B -import Data.List -import Data.Map qualified as M -import Data.String (IsString (fromString)) -import Data.Tagged (Tagged (..)) -import Debug.Trace -import Git qualified as G -import Git.Libgit2 qualified as GB -import Network.HTTP.Types.Method qualified as W -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 System.Directory (setCurrentDirectory) -import System.FilePath -import Text.Printf (printf) - -data Args = Args - { cmd :: Cmd - } - -args :: A.Parser Args -args = Args <$> cmd' - -data Cmd = Serve - -cmd' :: A.Parser Cmd -cmd' = - A.hsubparser . mconcat $ - [ A.command "serve" . A.info serveCmd $ - A.progDesc "Run webserver" - ] - -serveCmd :: A.Parser Cmd -serveCmd = pure Serve - -data Repo = Repo - { commits :: [Commit] - } - deriving (Show) - -data Commit = Commit - { id :: G.CommitOid GB.LgRepo, - collections :: [Collection] - } - deriving (Show) - -data Collection = Collection - { path :: FilePath, - files :: [FilePath], - schema :: Schema - } - 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 (M.mapWithKey toProperty ps)) - ] - where - toProperty k (U.Scalar "string") = "string" :: String - -main :: IO () -main = do - setCurrentDirectory "./blog" - let root = "." - ref = "HEAD" - repo <- G.openRepository GB.lgFactory G.defaultRepositoryOptions {G.repoPath = root} - repo <- G.runRepository GB.lgFactory repo do - Just cid <- fmap Tagged <$> G.resolveReference ref - c <- G.lookupCommit cid - cs <- mapM G.lookupCommit =<< G.listCommits Nothing cid - let showCommit c = G.commitLog c - fmap Repo . forM cs $ \c -> do - let cid = G.commitOid c - let tid = G.commitTree c - t <- G.lookupTree tid - fs <- - filter ((== ".json") . takeExtension) - . map B.toString - . map fst - <$> G.listTreeEntries t - let cls = M.toList (M.unionsWith (++) (map (\f -> M.singleton (takeDirectory f) [f]) fs)) - colls <- forM cls $ \(path, (file : files)) -> do - schema <- - fmap (fromAutoTypes path) . liftIO $ -- TODO read from HEAD - U.autoTypes file files - pure $ Collection path files schema - pure (Commit cid colls) - A.execParser (A.info (args <**> A.helper) A.idm) >>= \case - Args {cmd = Serve} -> do - W.runEnv 8080 $ \req respond -> do - case P.parseOnly routeP (W.rawPathInfo req) of - Right (SchemaJson path) -> do - let [c] = filter ((== path) . (.path)) (head repo.commits).collections - respond $ W.responseLBS W.status200 [] (J.encode c.schema) - (Debug.Trace.traceShowId -> !_) -> - respond $ W.responseLBS W.status200 [] "OK" - -data Route - = SchemaJson String - deriving (Show) - -routeP :: P.Parser Route -routeP = - ( SchemaJson - <$> (P.string "/" *> P.manyTill P.anyChar (P.string ".schema.json")) - ) - <* P.endOfInput diff --git a/backend/LICENSE b/backend/LICENSE new file mode 100644 index 0000000..c90516a --- /dev/null +++ b/backend/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2024, Alexander Foremny + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alexander Foremny nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/backend/app/Main.hs b/backend/app/Main.hs new file mode 100644 index 0000000..e75ce99 --- /dev/null +++ b/backend/app/Main.hs @@ -0,0 +1,132 @@ +module Main where + +import AutoTypes qualified as U +import AutoTypes.Unify qualified as U +import Control.Applicative ((<**>)) +import Control.Monad +import Control.Monad.Trans (liftIO) +import Data.Aeson qualified as J +import Data.Attoparsec.Char8 as P +import Data.ByteString.Char8 qualified as B +import Data.ByteString.Lazy.Char8 qualified as LB +import Data.ByteString.Lazy.UTF8 qualified as LB +import Data.ByteString.UTF8 qualified as B +import Data.List +import Data.Map qualified as M +import Data.String (IsString (fromString)) +import Data.Tagged (Tagged (..)) +import Debug.Trace +import Git qualified as G +import Git.Libgit2 qualified as GB +import Network.HTTP.Types.Method qualified as W +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 System.Directory (setCurrentDirectory) +import System.FilePath +import Text.Printf (printf) + +data Args = Args + { cmd :: Cmd + } + +args :: A.Parser Args +args = Args <$> cmd' + +data Cmd = Serve + +cmd' :: A.Parser Cmd +cmd' = + A.hsubparser . mconcat $ + [ A.command "serve" . A.info serveCmd $ + A.progDesc "Run webserver" + ] + +serveCmd :: A.Parser Cmd +serveCmd = pure Serve + +data Repo = Repo + { commits :: [Commit] + } + deriving (Show) + +data Commit = Commit + { id :: G.CommitOid GB.LgRepo, + collections :: [Collection] + } + deriving (Show) + +data Collection = Collection + { path :: FilePath, + files :: [FilePath], + schema :: Schema + } + 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 (M.mapWithKey toProperty ps)) + ] + where + toProperty k (U.Scalar "string") = "string" :: String + +main :: IO () +main = do + setCurrentDirectory "./blog" + let root = "." + ref = "HEAD" + repo <- G.openRepository GB.lgFactory G.defaultRepositoryOptions {G.repoPath = root} + repo <- G.runRepository GB.lgFactory repo do + Just cid <- fmap Tagged <$> G.resolveReference ref + c <- G.lookupCommit cid + cs <- mapM G.lookupCommit =<< G.listCommits Nothing cid + let showCommit c = G.commitLog c + fmap Repo . forM cs $ \c -> do + let cid = G.commitOid c + let tid = G.commitTree c + t <- G.lookupTree tid + fs <- + filter ((== ".json") . takeExtension) + . map B.toString + . map fst + <$> G.listTreeEntries t + let cls = M.toList (M.unionsWith (++) (map (\f -> M.singleton (takeDirectory f) [f]) fs)) + colls <- forM cls $ \(path, (file : files)) -> do + schema <- + fmap (fromAutoTypes path) . liftIO $ -- TODO read from HEAD + U.autoTypes file files + pure $ Collection path files schema + pure (Commit cid colls) + A.execParser (A.info (args <**> A.helper) A.idm) >>= \case + Args {cmd = Serve} -> do + W.runEnv 8081 $ \req respond -> do + case P.parseOnly routeP (W.rawPathInfo req) of + Right (SchemaJson path) -> do + let [c] = filter ((== path) . (.path)) (head repo.commits).collections + respond $ W.responseLBS W.status200 [] (J.encode c.schema) + (Debug.Trace.traceShowId -> !_) -> + respond $ W.responseLBS W.status200 [] "OK" + +data Route + = SchemaJson String + deriving (Show) + +routeP :: P.Parser Route +routeP = + ( SchemaJson + <$> (P.string "/" *> P.manyTill P.anyChar (P.string ".schema.json")) + ) + <* P.endOfInput diff --git a/backend/backend.cabal b/backend/backend.cabal new file mode 100644 index 0000000..1e3e3ed --- /dev/null +++ b/backend/backend.cabal @@ -0,0 +1,38 @@ +cabal-version: 3.4 +name: backend +version: 0.1.0.0 +license: BSD-3-Clause +license-file: LICENSE +maintainer: aforemny@posteo.de +author: Alexander Foremny +build-type: Simple + +executable backend + main-is: Main.hs + hs-source-dirs: app + default-language: GHC2021 + default-extensions: + BlockArguments LambdaCase OverloadedStrings ViewPatterns + OverloadedRecordDot NoFieldSelectors + + ghc-options: -Wall -threaded + build-depends: + aeson, + astore, + attoparsec, + autotypes, + base, + bytestring, + containers, + directory, + filepath, + gitlib, + gitlib-libgit2, + hlibgit2, + http-types, + mtl, + optparse-applicative, + tagged, + utf8-string, + wai, + warp diff --git a/cabal.project b/cabal.project index f641ad1..f44a24c 100644 --- a/cabal.project +++ b/cabal.project @@ -1 +1 @@ -packages: ./*.cabal autotypes/*.cabal +packages: */*.cabal diff --git a/default.nix b/default.nix index 060a4c7..b2c6d83 100644 --- a/default.nix +++ b/default.nix @@ -2,22 +2,40 @@ , sources ? import ./nix/sources.nix }: let - haskellPackages = pkgs.haskellPackages.override { + haskellPackages = pkgs.haskell.packages.ghc98.override { overrides = self: super: { - acms = self.callCabal2nix "acms" ./. { }; astore = self.callCabal2nix "astore" sources.json2sql { }; autotypes = self.callCabal2nix "autotypes" ./autotypes { }; - json2sql = self.callCabal2nix "json2sql" sources.json2sql { }; + backend = self.callCabal2nix "backend" ./backend { }; + frontend = self.callCabal2nix "frontend" ./frontend { }; + websockets = pkgs.haskell.lib.doJailbreak super.websockets; + }; + }; + + jsHaskellPackages = pkgs.pkgsCross.ghcjs.haskell.packages.ghc98.override { + overrides = self: super: { + frontend = self.callCabal2nix "frontend" ./frontend { }; }; }; in rec { - inherit (haskellPackages) acms; + inherit (haskellPackages) backend; + inherit (jsHaskellPackages) frontend; shell = haskellPackages.shellFor { - packages = _: [ acms haskellPackages.autotypes ]; + packages = _: [ + haskellPackages.autotypes + haskellPackages.backend + haskellPackages.frontend + ]; buildInputs = [ haskellPackages.cabal-install haskellPackages.ormolu + (pkgs.writeScriptBin "reload" '' + set -efu + ${haskellPackages.ghcid.bin}/bin/ghcid -c \ + '${haskellPackages.cabal-install}/bin/cabal new-repl' \ + -T ':run Main.main' + '') ]; withHoogle = true; withHaddock = true; diff --git a/frontend/LICENSE b/frontend/LICENSE new file mode 100644 index 0000000..c90516a --- /dev/null +++ b/frontend/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2024, Alexander Foremny + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alexander Foremny nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/frontend/app/Main.hs b/frontend/app/Main.hs new file mode 100644 index 0000000..d1bb89e --- /dev/null +++ b/frontend/app/Main.hs @@ -0,0 +1,77 @@ +module Main where + +#ifndef ghcjs_HOST_OS +import Language.Javascript.JSaddle.Warp as JSaddle +#endif + +import Data.ByteString.UTF8 qualified as B +import Data.Maybe +import Miso +import Miso.String + +#ifndef ghcjs_HOST_OS +import Network.HTTP.Simple +import Data.String +#else +import JavaScript.Web.XMLHttpRequest +#endif + +type Model = Maybe Schema + +type Schema = String + +data Action + = FetchSchema + | SetSchema Schema + deriving (Show, Eq) + +#ifndef ghcjs_HOST_OS +runApp :: JSM () -> IO () +runApp f = JSaddle.debugOr 8080 (f >> syncPoint) JSaddle.jsaddleApp +#else +runApp :: IO () -> IO () +runApp app = app +#endif + +main :: IO () +main = runApp $ startApp App {..} + where + initialAction = FetchSchema + model = Nothing + update = updateModel + view = viewModel + events = defaultEvents + subs = [] + mountPoint = Nothing + logLevel = Off + +updateModel :: Action -> Model -> Effect Action Model +updateModel action m = + case action of + FetchSchema -> m <# do SetSchema <$> fetchSchema + SetSchema schema -> noEff (Just schema) + +fetchSchema :: JSM String +fetchSchema = fetch "http://localhost:8081/posts.schema.json" + +#ifndef ghcjs_HOST_OS +fetch :: String -> JSM String +fetch url = B.toString . getResponseBody <$> httpBS (fromString url) +#else +fetch :: String -> JSM String +fetch url = maybe "" B.toString . contents <$> xhrByteString req + where + req = + Request + { reqMethod = GET, + reqURI = pack url, + reqLogin = Nothing, + reqHeaders = [], + reqWithCredentials = False, + reqData = NoData + } +#endif + +viewModel :: Model -> View Action +viewModel schema = + div_ [] [text (toMisoString (fromMaybe ".." schema))] diff --git a/frontend/frontend.cabal b/frontend/frontend.cabal new file mode 100644 index 0000000..5674bb7 --- /dev/null +++ b/frontend/frontend.cabal @@ -0,0 +1,31 @@ +cabal-version: 3.4 +name: frontend +version: 0.1.0.0 +license: BSD-3-Clause +license-file: LICENSE +maintainer: aforemny@posteo.de +author: Alexander Foremny +build-type: Simple +extra-doc-files: CHANGELOG.md + +executable frontend + main-is: Main.hs + hs-source-dirs: app + default-language: GHC2021 + default-extensions: CPP OverloadedStrings RecordWildCards + ghc-options: -Wall + build-depends: + base, + bytestring, + containers, + miso, + text, + utf8-string + + if !arch(javascript) + build-depends: jsaddle-warp + + if arch(javascript) + build-depends: ghcjs-base + else + build-depends: http-conduit diff --git a/nix/sources.json b/nix/sources.json index 21ed699..38375d4 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -11,10 +11,10 @@ "homepage": null, "owner": "NixOS", "repo": "nixpkgs", - "rev": "6c43a3495a11e261e5f41e5d7eda2d71dae1b2fe", - "sha256": "16f329z831bq7l3wn1dfvbkh95l2gcggdwn6rk3cisdmv2aa3189", + "rev": "a7d95e2b0029b8ee30facbe664b62968c59b46a6", + "sha256": "0vprwa4h794bjd92arjnzdm8lb8mg3xvpfmqbk723zcxnvmpnafn", "type": "tarball", - "url": "https://github.com/NixOS/nixpkgs/archive/6c43a3495a11e261e5f41e5d7eda2d71dae1b2fe.tar.gz", + "url": "https://github.com/NixOS/nixpkgs/archive/a7d95e2b0029b8ee30facbe664b62968c59b46a6.tar.gz", "url_template": "https://github.com///archive/.tar.gz" } } -- cgit v1.2.3