move Collection types to common

10 files changed, 81 insertions, 64 deletions

diff --git a/backend/backend.cabal b/backend/backend.cabal
index ac82e25..c8bff6f 100644
--- a/backend/backend.cabal
+++ b/backend/backend.cabal
@@ -23,6 +23,7 @@ library
         aeson,
         base,
         bytestring,
+        common,
         exceptions,
         miso,
         text,
diff --git a/backend/lib/ACMS/API/REST/Collection.hs b/backend/lib/ACMS/API/REST/Collection.hs
index 7be3269..09f7e32 100644
--- a/backend/lib/ACMS/API/REST/Collection.hs
+++ b/backend/lib/ACMS/API/REST/Collection.hs
@@ -11,6 +11,7 @@ import Data.Maybe
 import JavaScript.Web.XMLHttpRequest
 import Miso.String qualified as J
 #endif
+import Collection
 import ACMS.API.REST (APIMonad, fetch, restRequest)
 import Data.Aeson qualified as A
 import Data.Function ((&))
@@ -18,43 +19,43 @@ import Miso.String (MisoString)
 import Text.Printf (printf)
 import Debug.Trace
 
-list :: (APIMonad m) => MisoString -> m [A.Object]
+list :: (APIMonad m) => Collection -> m [A.Object]
 list c =
-  restRequest (printf "/collection/%s" c)
+  restRequest (printf "/collection/%s" c.name)
     & fetch
     >>= A.throwDecode
 
-read :: (APIMonad m) => MisoString -> MisoString -> m [A.Object]
-read c i =
-  restRequest (printf "/collection/%s/%s" c i)
+read :: (APIMonad m) => CollectionItem -> m [A.Object]
+read ci =
+  restRequest (printf "/collection/%s/%s" ci.collection.name ci.itemFileName)
     & fetch
     >>= A.throwDecode
 
-update :: (APIMonad m) => MisoString -> MisoString -> A.Object -> m A.Object
-update c i o =
-  restRequest (printf "/collection/%s/%s" c i)
+update :: (APIMonad m) => CollectionItem -> A.Object -> m A.Object
+update ci o =
+  restRequest (printf "/collection/%s/%s" ci.collection.name ci.itemFileName)
     & setRequestMethod "PUT"
     & setRequestBodyLBS (A.encode o)
     & fetch
     >>= A.throwDecode
 
-create :: (APIMonad m) => MisoString -> A.Object -> m A.Object
+create :: (APIMonad m) => Collection -> A.Object -> m A.Object
 create c o = do
-  restRequest (printf "/collection/%s" c)
+  restRequest (printf "/collection/%s" c.name)
     & setRequestMethod "POST"
     & setRequestBodyLBS (A.encode o)
     & fetch
     >>= A.throwDecode
 
-delete :: (APIMonad m) => MisoString -> MisoString -> m [A.Object]
-delete c i =
-  restRequest (printf "/collection/%s/%s" c i)
+delete :: (APIMonad m) => CollectionItem -> m [A.Object]
+delete ci =
+  restRequest (printf "/collection/%s/%s" ci.collection.name ci.itemFileName)
     & setRequestMethod "DELETE"
     & fetch
     >>= A.throwDecode
 
-schema :: (APIMonad m) => (A.FromJSON a) => MisoString -> m a
+schema :: (APIMonad m) => (A.FromJSON a) => Collection -> m a
 schema c =
-  restRequest (printf "/collection/%s/schema" c)
+  restRequest (printf "/collection/%s/schema" c.name)
     & fetch
     >>= A.throwDecode
diff --git a/cli/app/Main.hs b/cli/app/Main.hs
index ef7a8ad..991eaa5 100644
--- a/cli/app/Main.hs
+++ b/cli/app/Main.hs
@@ -8,6 +8,7 @@
 
 module Main where
 
+import Collection
 import ACMS.API.REST.Collection qualified
 import Control.Applicative ((<**>))
 import Data.Aeson qualified as J
@@ -20,7 +21,7 @@ import Text.ParserCombinators.ReadPrec qualified as R
 import Text.Read (Read (..))
 import Debug.Trace
 
-data Args = Args
+newtype Args = Args
   { cmd :: Cmd
   }
 
@@ -44,28 +45,6 @@ data CollectionCmd
   | --
     CollectionSchema Collection
 
-newtype Collection = Collection T.Text
-  deriving (Read)
-
-data CollectionItem = CollectionItem
-  { collection :: Collection,
-    itemFileName :: T.Text
-  }
-
-instance Read CollectionItem where
-  readPrec = R.lift do
-    (Collection . T.pack -> collection) <- R.munch (/= '/')
-    _ <- R.string "/"
-    (T.pack -> itemFileName) <- do
-      itemFileName <- R.munch (liftA2 (&&) (/= '.') (/= '/'))
-      fileExt <- R.string ".json"
-      pure (itemFileName <> fileExt)
-    pure CollectionItem {..}
-
-instance Show CollectionItem where
-  show (CollectionItem {collection = Collection cn, itemFileName}) =
-    show (cn <> "/" <> itemFileName)
-
 collectionCmd :: O.Parser Cmd
 collectionCmd = do
   fmap CollectionCmd . O.hsubparser . mconcat $
@@ -96,22 +75,22 @@ main =
     Args
       { cmd = CollectionCmd cmd
       } -> case cmd of
-        CollectionAdd (Collection cn) -> do
+        CollectionAdd collection -> do
           LB.putStr . J.encodePretty
-            =<< ACMS.API.REST.Collection.create cn
+            =<< ACMS.API.REST.Collection.create collection
             =<< J.throwDecode
             =<< LB.getContents
-        CollectionView CollectionItem {collection = Collection cn, itemFileName} ->
+        CollectionView collectionItem ->
           LB.putStr . J.encodePretty
-            =<< ACMS.API.REST.Collection.read cn itemFileName
-        CollectionDelete CollectionItem {collection = Collection cn, itemFileName} ->
+            =<< ACMS.API.REST.Collection.read collectionItem
+        CollectionDelete collectionItem ->
           LB.putStr . J.encodePretty
-            =<< ACMS.API.REST.Collection.delete cn itemFileName
-        CollectionEdit CollectionItem {collection = Collection cn, itemFileName} ->
+            =<< ACMS.API.REST.Collection.delete collectionItem
+        CollectionEdit collectionItem ->
           LB.putStr . J.encodePretty
-            =<< ACMS.API.REST.Collection.update cn itemFileName
+            =<< ACMS.API.REST.Collection.update collectionItem
             =<< J.throwDecode
             =<< LB.getContents
-        CollectionSchema (Collection cn) ->
+        CollectionSchema collection ->
           LB.putStr . J.encodePretty @J.Value
-            =<< ACMS.API.REST.Collection.schema cn
+            =<< ACMS.API.REST.Collection.schema collection
diff --git a/cli/cli.cabal b/cli/cli.cabal
index 4a21270..5617808 100644
--- a/cli/cli.cabal
+++ b/cli/cli.cabal
@@ -20,6 +20,7 @@ executable acms
         backend,
         base,
         bytestring,
+        common,
         filepath,
         optparse-applicative,
         sh,
diff --git a/common/common.cabal b/common/common.cabal
index 738d8be..2c98a47 100644
--- a/common/common.cabal
+++ b/common/common.cabal
@@ -1,6 +1,6 @@
 cabal-version:   3.4
 name:            common
-version:         0.1.0.0
+version:         0.2.0
 license:         BSD-3-Clause
 license-file:    LICENSE
 maintainer:      aforemny@posteo.de
@@ -9,7 +9,8 @@ build-type:      Simple
 extra-doc-files: CHANGELOG.md
 
 library
-    exposed-modules:    Version
+    exposed-modules:    Version,
+                        Collection
     hs-source-dirs:     src
     default-language:   GHC2021
     default-extensions: ViewPatterns
diff --git a/common/src/Collection.hs b/common/src/Collection.hs
new file mode 100644
index 0000000..a23fd31
--- /dev/null
+++ b/common/src/Collection.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+module Collection where
+
+import Data.Text qualified as T
+import Text.ParserCombinators.ReadP qualified as R
+import Text.ParserCombinators.ReadPrec qualified as R
+import Text.Read (Read (..))
+
+newtype Collection = Collection {name :: T.Text}
+  deriving (Read, Eq, Show)
+
+data CollectionItem = CollectionItem
+  { collection :: Collection,
+    itemFileName :: FilePath
+  } deriving (Eq)
+
+instance Read CollectionItem where
+  readPrec = R.lift $ do
+    (Collection . T.pack -> collection) <- R.munch (/= '/')
+    _ <- R.string "/"
+    itemFileName <- do
+      itemFileName <- R.munch (liftA2 (&&) (/= '.') (/= '/'))
+      fileExt <- R.string ".json"
+      pure (itemFileName <> fileExt)
+    pure CollectionItem {..}
+
+instance Show CollectionItem where
+  show (CollectionItem {collection = Collection cn, itemFileName}) =
+    show (cn <> "/" <> T.pack itemFileName)
diff --git a/default.nix b/default.nix
index 5fa2da4..9e66c80 100644
--- a/default.nix
+++ b/default.nix
@@ -21,6 +21,7 @@ rec {
       haskellPackages.astore
       haskellPackages.autotypes
       haskellPackages.cabal-install
+      haskellPackages.haskell-language-server
       haskellPackages.ormolu
       pkgs.niv
       (pkgs.writeScriptBin "reload" ''
diff --git a/frontend/app/Page.hs b/frontend/app/Page.hs
index c7b393f..e1c8415 100644
--- a/frontend/app/Page.hs
+++ b/frontend/app/Page.hs
@@ -7,12 +7,14 @@ module Page
   )
 where
 
+import Collection
 import Control.Monad.Catch (SomeException)
 import Data.Bifunctor
 import Data.Default
 import Data.Function
 import Effect (Eff)
 import Miso
+import Miso.String (fromMisoString)
 import Page.EditValue qualified as EditValue
 import Page.ListCollection qualified as ListCollection
 import Page.NewCollection qualified as NewCollection
@@ -34,9 +36,9 @@ instance Default Page where
 initialPage :: Route -> JSM (Either SomeException Page)
 initialPage Route.Home = pure (Right Home)
 initialPage (Route.ListCollection c) =
-  fmap ListCollection <$> ListCollection.initialModel c
+  fmap ListCollection <$> ListCollection.initialModel (Collection (fromMisoString c))
 initialPage (Route.EditValue c f) =
-  fmap EditValue <$> EditValue.initialModel c f
+  fmap EditValue <$> EditValue.initialModel (CollectionItem (Collection (fromMisoString c)) (fromMisoString f))
 initialPage Route.NewCollection =
   fmap NewCollection <$> NewCollection.initialModel
 
diff --git a/frontend/app/Page/EditValue.hs b/frontend/app/Page/EditValue.hs
index feacd4a..4ff867f 100644
--- a/frontend/app/Page/EditValue.hs
+++ b/frontend/app/Page/EditValue.hs
@@ -15,22 +15,22 @@ import Data.Maybe
 import Effect (Eff)
 import Form qualified as F
 import Miso
-import Miso.String (MisoString, toMisoString)
+import Miso.String (toMisoString)
 import Safe (headMay)
 import Schema
+import Collection
 
 data Model = Model
-  { collection :: MisoString,
-    fileName :: MisoString,
+  { collectionItem :: CollectionItem,
     input :: Maybe A.Object,
     schema :: Schema
   }
   deriving (Show, Eq)
 
-initialModel :: MisoString -> MisoString -> JSM (Either SomeException Model)
-initialModel collection fileName = do
-  schema' <- try (API.REST.Collection.schema collection)
-  input' <- try (headMay <$> API.REST.Collection.read collection fileName)
+initialModel :: CollectionItem -> JSM (Either SomeException Model)
+initialModel collectionItem = do
+  schema' <- try (API.REST.Collection.schema collectionItem.collection)
+  input' <- try (headMay <$> API.REST.Collection.read collectionItem)
   pure do
     schema <- schema'
     input <- input'
@@ -43,7 +43,7 @@ update__formChanged (Just -> input) = Action $ \m -> (noEff m {input}, [])
 
 update__formSubmitted :: A.Object -> Action
 update__formSubmitted output = Action $ \m ->
-  (m <# do update__entityWritten <$> try (API.REST.Collection.update m.collection m.fileName output), [])
+  (m <# do update__entityWritten <$> try (API.REST.Collection.update m.collectionItem output), [])
 
 update__entityWritten :: Either SomeException A.Object -> Action
 update__entityWritten _ = Action $ \m -> (noEff m, [])
diff --git a/frontend/app/Page/ListCollection.hs b/frontend/app/Page/ListCollection.hs
index 47a4649..6b999f0 100644
--- a/frontend/app/Page/ListCollection.hs
+++ b/frontend/app/Page/ListCollection.hs
@@ -13,18 +13,18 @@ import Data.Aeson qualified as A
 import Data.Aeson.KeyMap qualified as AM
 import Effect (Eff)
 import Miso
-import Miso.String (MisoString)
 import Schema
+import Collection
 
 data Model = Model
-  { collection :: MisoString,
+  { collection :: Collection,
     input :: A.Object,
     schema :: Schema,
     posts :: [A.Object]
   }
   deriving (Show, Eq)
 
-initialModel :: MisoString -> JSM (Either SomeException Model)
+initialModel :: Collection -> JSM (Either SomeException Model)
 initialModel collection = do
   schema' <- try (API.REST.Collection.schema collection)
   posts' <- try (API.REST.Collection.list collection)
@@ -42,7 +42,7 @@ viewModel :: Model -> View Action
 viewModel m =
   div_ [] $
     [ h3_ [] [text "entities"],
-      schemaTable m.collection m.schema m.posts,
+      schemaTable m.collection.name m.schema m.posts,
       h3_ [] [text "schema"],
       viewSchema m.schema
     ]