add schema version

backend/app/Main.hs

@@ -15,6 +15,8 @@ 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.Map.Merge.Strict qualified as M
+import Data.Maybe
 import Data.String (IsString (fromString))
 import Data.Tagged (Tagged (..), untag)
 import Debug.Trace
@@ -25,11 +27,13 @@ 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 (setCurrentDirectory)
 import System.FilePath
 import System.INotify
 import Text.Printf (printf)
+import Version
 
 data Args = Args
   { cmd :: Cmd
@@ -57,7 +61,8 @@ data Repo = Repo
 
 data Commit = Commit
   { id :: G.CommitOid GB.LgRepo,
-    collections :: [Collection]
+    collections :: [Collection],
+    schemaVersion :: Version
   }
   deriving (Show)
 
@@ -110,22 +115,78 @@ initRepo root ref = do
     Just cid <- fmap Tagged <$> G.resolveReference ref
     c <- G.lookupCommit cid
     cs <- mapM G.lookupCommit =<< G.listCommits Nothing cid
-    fmap Repo . forM cs $ \c -> do
-      let cid = G.commitOid c
-      fs <-
-        fmap (filter ((== ".json") . takeExtension)) . liftIO $
-          Q.withStore root ref do
-            Q.withCommit cid Q.listAllFiles
-      let cls =
-            M.toList . M.unionsWith (++) $
-              map (\f -> M.singleton (takeDirectory f) [f]) fs
-      colls <- forM cls $ \(makeRelative "/" -> path, (file : files)) -> do
-        (value : values) <- do
-          liftIO $ Q.withStore root ref do
-            mapM (Q.withCommit cid . Q.readFile) (file : files)
-        let schema = fromAutoTypes path $ U.autoTypes' value values
-        pure $ Collection path files schema
-      pure (Commit cid colls)
+    fmap (Repo . reverse) $
+      foldM
+        ( \cs c -> do
+            let cid = G.commitOid c
+            fs <-
+              fmap (filter ((== ".json") . takeExtension)) . 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, (file : files)) -> do
+              (value : values) <- do
+                liftIO $ Q.withStore root ref do
+                  mapM (Q.withCommit cid . Q.readFile) (file : files)
+              let schema = fromAutoTypes path $ U.autoTypes' value values
+              pure $ Collection path files schema
+            let schemaVersion =
+                  case lastMay 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
+            pure (c : cs)
+        )
+        []
+        cs
+
+compareSchemas ::
+  M.Map String Schema ->
+  M.Map String Schema ->
+  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 (Just _) = Just Patch
+    compareSchemas' (Just _) Nothing = Just Patch
+    compareSchemas' (Just schema') (Just schema) = compareSchema schema' schema
+
+-- TODO
+compareSchema :: Schema -> Schema -> Maybe SchemaDifference
+compareSchema schema' schema = Nothing
+
+data SchemaDifference
+  = Major
+  | Minor
+  | Patch
+  deriving (Eq, Ord)
 
 main :: IO ()
 main = do
@@ -146,21 +207,28 @@ main = do
             q <-
               fromString @Q.Query . LB.toString
                 <$> W.lazyRequestBody req
-            r <- liftIO $ Q.withStore root ref (Q.query q)
+            r <- liftIO $ Q.withStore root ref do Q.query q
             respond . W.responseLBS W.status200 [] $ J.encode r
-          (Debug.Trace.traceShowId -> !_) ->
+          Right SchemaVersion -> do
+            repo <- atomically (readTMVar repoT)
+            respond $
+              W.responseLBS W.status200 [] $
+                J.encode (last repo.commits).schemaVersion
+          (traceShowId -> !_) ->
             respond $ W.responseLBS W.status200 [] "not implemented"
 
 data Route
   = SchemaJson String
   | Query
+  | SchemaVersion
   deriving (Show)
 
 routeP :: P.Parser Route
 routeP =
   ( P.choice
       [ SchemaJson <$> (P.string "/" *> P.manyTill P.anyChar (P.string ".schema.json")),
-        pure Query <* (P.string "/")
+        pure SchemaVersion <* P.string "/schemaVersion",
+        pure Query <* P.string "/"
       ]
   )
     <* P.endOfInput

backend/backend.cabal

@@ -23,6 +23,7 @@ executable backend
         autotypes,
         base,
         bytestring,
+        common,
         containers,
         directory,
         filepath,
@@ -33,8 +34,11 @@ executable backend
         http-types,
         mtl,
         optparse-applicative,
+        safe,
+        split,
         stm,
         tagged,
+        text,
         utf8-string,
         wai,
         warp

common/CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for common
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

common/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.

common/common.cabal

@@ -0,0 +1,21 @@
+cabal-version:   3.4
+name:            common
+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
+
+library
+    exposed-modules:    Version
+    hs-source-dirs:     src
+    default-language:   GHC2021
+    default-extensions: ViewPatterns
+    ghc-options:        -Wall
+    build-depends:
+        aeson,
+        base,
+        split,
+        text

common/src/Version.hs

@@ -0,0 +1,36 @@
+module Version
+  ( Version (..),
+    versionToString,
+    versionFromText,
+    versionFromString,
+  )
+where
+
+import Data.Aeson qualified as A
+import Data.Aeson.Types qualified as A
+import Data.List
+import Data.List.Split
+import Data.Text qualified as T
+
+data Version = Version Int Int Int
+  deriving (Show, Eq)
+
+instance A.ToJSON Version where
+  toJSON =
+    A.toJSON . versionToString
+
+instance A.FromJSON Version where
+  parseJSON (A.String (versionFromText -> Just version)) = pure version
+  parseJSON v = A.typeMismatch "version" v
+
+versionToString :: Version -> String
+versionToString (Version major minor patch) =
+  intercalate "." (map show [major, minor, patch])
+
+versionFromString :: String -> Maybe Version
+versionFromString (map read . splitOn "." -> [major, minor, patch]) =
+  Just (Version major minor patch)
+versionFromString _ = Nothing
+
+versionFromText :: T.Text -> Maybe Version
+versionFromText = versionFromString . T.unpack

default.nix

@@ -7,6 +7,7 @@ let
       astore = self.callCabal2nix "astore" sources.json2sql { };
       autotypes = self.callCabal2nix "autotypes" ./autotypes { };
       backend = self.callCabal2nix "backend" ./backend { };
+      common = self.callCabal2nix "common" ./common { };
       frontend = self.callCabal2nix "frontend" ./frontend { };
       websockets = pkgs.haskell.lib.doJailbreak super.websockets;
     };
@@ -14,6 +15,7 @@ let
 
   jsHaskellPackages = pkgs.pkgsCross.ghcjs.haskell.packages.ghc98.override {
     overrides = self: super: {
+      common = self.callCabal2nix "common" ./common { };
       frontend = self.callCabal2nix "frontend" ./frontend { };
     };
   };
@@ -25,6 +27,7 @@ rec {
     packages = _: [
       haskellPackages.autotypes
       haskellPackages.backend
+      haskellPackages.common
       haskellPackages.frontend
     ];
     buildInputs = [

frontend/app/Api.hs

@@ -2,6 +2,7 @@
 
 module Api
   ( fetchSchema,
+    fetchSchemaVersion,
     fetchPosts,
     fetchPost,
     updatePost,
@@ -25,11 +26,16 @@ import Data.Function
 import Miso
 import Safe
 import Schema
+import Version
 
 fetchSchema :: JSM (Either String Schema)
 fetchSchema =
   A.eitherDecode <$> fetch (fromString "http://localhost:8081/posts.schema.json")
 
+fetchSchemaVersion :: JSM (Either String Version)
+fetchSchemaVersion =
+  A.eitherDecode <$> fetch (fromString "http://localhost:8081/schemaVersion")
+
 fetchPosts :: JSM (Either String [A.Value])
 fetchPosts =
   A.eitherDecode

frontend/app/Main.hs

@@ -4,24 +4,38 @@ module Main where
 import Language.Javascript.JSaddle.Warp as JSaddle
 #endif
 
+import Api
 import Data.Bifunctor
 import Data.Default
 import Data.Function
-import GHC.Generics (Generic)
 import Miso
 import Miso.String (toMisoString)
 import NeatInterpolation qualified as Q
 import Page (Page, initialPage, updatePage, viewPage)
 import Page qualified as Page
 import Route (parseURI)
+import Version
 
-data Model = Model
-  { page :: Maybe (Either String Page)
+data Model
+  = Loading
+  | Failed String
+  | Loaded LoadedState
+  deriving (Show, Eq)
+
+data LoadedState = LoadedState
+  { page :: Maybe (Either String Page),
+    schemaVersion :: Version
   }
-  deriving (Show, Eq, Generic, Default)
+  deriving (Show, Eq)
+
+instance Default Model where
+  def = Loading
 
 data Action
-  = NoOp
+  = -- Loading
+    SetLoaded (Either String LoadedState)
+  | -- Loaded
+    NoOp
   | Init URI
   | HandleURI URI
   | HandlePage Page.Action
@@ -50,34 +64,43 @@ main = runApp $ do
     logLevel = Off
 
 updateModel :: Action -> Model -> Effect Action Model
-updateModel NoOp m = noEff m
-updateModel (Init uri) m =
-  m <# do
-    SetPage <$> initialPage (parseURI uri)
-updateModel (HandleURI uri) m =
-  m <# do
+updateModel _ (Failed err) = noEff (Failed err)
+updateModel (Init uri) Loading =
+  Loading <# do
+    page <- Just <$> initialPage (parseURI uri)
+    schemaVersion' <- fetchSchemaVersion
+    pure $ SetLoaded do
+      schemaVersion <- schemaVersion'
+      pure LoadedState {..}
+updateModel (Init _) m = noEff m
+updateModel (SetLoaded (Left err)) Loading = noEff (Failed err)
+updateModel (SetLoaded (Right state)) Loading = noEff (Loaded state)
+updateModel (SetLoaded _) m = noEff m
+updateModel _ Loading = noEff Loading
+updateModel NoOp (Loaded s) = noEff (Loaded s)
+updateModel (HandleURI uri) (Loaded s) =
+  Loaded s <# do
     let route = parseURI uri
     SetPage <$> initialPage route
-updateModel (SetPage page) m = noEff m {page = Just page}
-updateModel (HandlePage action) m =
-  case m.page of
+updateModel (SetPage page) (Loaded s) = noEff (Loaded s {page = Just page})
+updateModel (HandlePage action) (Loaded s) =
+  case s.page of
     Just (Right page) ->
-      updatePage action page
-        & bimap HandlePage (\page -> m {page = Just (Right page)})
-    _ -> noEff m
+      fmap Loaded $
+        updatePage action page
+          & bimap HandlePage (\page -> s {page = Just (Right page)})
+    _ -> noEff (Loaded s)
 
 viewModel :: Model -> View Action
-viewModel model =
+viewModel Loading = text ".."
+viewModel (Failed s) = err s
+viewModel (Loaded s) =
   div_ [] $
     [ viewCss,
-      viewHeader,
+      viewHeader s,
       nav_ [] [viewCollections],
       main_ [] $
-        [ HandlePage
-            <$> maybe
-              (text "..")
-              (either err viewPage)
-              model.page
+        [ HandlePage <$> maybe (text "..") (either err viewPage) s.page
         ]
     ]
 
@@ -171,16 +194,19 @@ th, td {
 err :: String -> View action
 err = text . toMisoString . ("err! " <>)
 
-viewHeader :: View Action
-viewHeader =
+viewHeader :: LoadedState -> View Action
+viewHeader s =
   header_ [] $
     [ section_ [] [h1_ [] [a_ [href_ "#"] [text "acms"]]],
-      section_ [] [viewBranch]
+      section_ [] (viewBranch s)
     ]
 
-viewBranch :: View Action
-viewBranch =
-  select_ [] [option_ [] [text "main"]]
+viewBranch :: LoadedState -> [View Action]
+viewBranch s =
+  [ text (toMisoString (versionToString s.schemaVersion)),
+    text " ",
+    select_ [] [option_ [] [text "main"]]
+  ]
 
 viewCollections :: View Action
 viewCollections =

frontend/frontend.cabal

@@ -37,11 +37,13 @@ executable frontend
         attoparsec,
         base,
         bytestring,
+        common,
         containers,
         data-default,
         miso,
         neat-interpolation,
         safe,
+        split,
         text,
         utf8-string
 

nix/sources.json

@@ -2,7 +2,7 @@
     "json2sql": {
         "branch": "main",
         "repo": "git@code.nomath.org:~/json2sql",
-        "rev": "d8b2af98f594e4fc5cc4919c1efe95e1d8d9aafe",
+        "rev": "906d9ebba1ae08ea73acb55b536ff2f49e1b55c0",
         "type": "git"
     },
     "nixpkgs": {