support comment without known user

aggreact.cabal

@@ -1,8 +1,10 @@
--- This file has been generated from package.yaml by hpack version 0.28.2.
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.31.2.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: b4988a3c9435d94fc18d9e5063a020aa1bd3ef2b958b49a1fde23a8d052be970
+-- hash: 5edc28ddb6ddbaae8fca1102380d6eca821d473ed494bca0e66de11e29600b9f
 
 name:           aggreact
 version:        0.1.0.0
@@ -16,7 +18,6 @@ copyright:      © 2018 Yann Esposito
 license:        ISC
 license-file:   LICENSE
 build-type:     Simple
-cabal-version:  >= 1.10
 extra-source-files:
     README.md
     stack.yaml

src/Aggreact/Comments/Types.hs

@@ -52,7 +52,7 @@ where
 
 import           Protolude
 
-import           Aggreact.Users                   (User, UserId)
+import           Aggreact.Users                   (User, UserId(..))
 
 import qualified Control.Exception                as Ex
 import           Data.Aeson                       (FromJSON (..), ToJSON (..),
@@ -102,13 +102,16 @@ instance IxSet.Indexable CommentIxs Comment where
 -- ** CommentView
 
 -- | A CommentView is a comment along its creator infos
-data CommentView = CommentView Comment User
+data CommentView = CommentView Comment (Maybe User)
   deriving (Eq,Ord,Data,Typeable,Generic,Show)
 
 -- Web
 deriving instance ToJSON CommentView
 -- SQLite Select
 instance FromRow CommentView where fromRow = CommentView <$> fromRow <*> fromRow
+
+instance FromRow (Maybe User) where fromRow = (SQL.genericFromRow :: RowParser User)
+
 -- Indexing
 type CommentViews = IxSet.IxSet CommentViewIxs CommentView
 type CommentViewIxs = '[Id,ParentId,Slug,Content,UserId,Term]
@@ -129,7 +132,7 @@ data NewComment =
   { parent  :: ParentId -- ^ UUID
   , slug    :: Slug     -- ^ Text (URL)
   , content :: Content  -- ^ Text
-  , userid  :: UserId   -- ^ UUID
+  , userid  :: MUserId   -- ^ UUID
   } deriving (Generic,Typeable,Data,Eq,Ord,Show)
 
 -- Web
@@ -155,6 +158,17 @@ instance IxSet.Indexable NewCommentIxs Comment where
             (IxSet.ixGen (Proxy :: Proxy UserId))
             (IxSet.ixFun getTerms)
 
+
+-- *** Field MUserId
+newtype MUserId = MUserId (Maybe UserId) deriving (Eq,Ord,Show,Generic,Data)
+deriving anyclass instance FromJSON  MUserId
+deriving anyclass instance ToJSON    MUserId
+deriving newtype instance ToField MUserId
+deriving newtype instance FromField MUserId
+instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (MUserId ': rest) where
+  toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
+
+
 -- *** Field ParentId
 newtype ParentId = ParentId (Maybe UUID) deriving (Eq,Ord,Show,Generic,Data)
 deriving anyclass instance FromJSON  ParentId
@@ -194,6 +208,15 @@ instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Content ': rest)
 
 newtype Term = Term Text deriving (Eq,Ord,Generic)
 
+instance FormI.FromHttpApiData MUserId where
+  parseUrlPiece s = do
+    txt <- FormI.parseUrlPiece s
+    if Text.null txt
+      then return (MUserId Nothing)
+      else case UUID.fromText txt of
+               Nothing   -> Left $ "Parent ID is not an UUID (" <> txt <> ")"
+               Just uuid -> return (MUserId (Just (UserId (toS uuid))))
+
 instance FormI.FromHttpApiData ParentId where
   parseUrlPiece s = do
     txt <- FormI.parseUrlPiece s