Federated forge server

[[ 🗃 ^rjQ3E vervis ]] :: [📥 Inbox] [📤 Outbox] [🐤 Followers] [🤝 Collaborators] [🛠 Commits]

Clone

HTTPS: git clone https://vervis.peers.community/repos/rjQ3E

SSH: git clone USERNAME@vervis.peers.community:rjQ3E

Branches

Tags

main :: src / Data /

F3.hs

{- This file is part of Vervis.
 -
 - Written in 2024 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

module Data.F3
    ( Identifier
    , Markdown
    , Comment (..)
    , IssueState (..)
    , Issue (..)
    , ExtIssueTracker (..)
    , Reaction (..)
    , Vcs (..)
    , ExtRepo (..)
    )
where

import Control.Monad
import Data.Aeson
import Data.Maybe
import Data.Text (Text)
import Data.Time.Clock

import Web.Text

import Data.Aeson.Local

infixr 8 .=??
(.=??) :: ToJSON v => Key -> Maybe v -> Maybe (Key, Value)
k .=?? mv = (k .=) <$> mv

-- Custom extensions:
--
-- * New properties prefixed with @ext@
-- * New object types prefixed with @Ext@

type Identifier = Text

type Markdown = Text

data Comment = Comment
    { commentIndex     :: Identifier
    , commentPoster    :: Identifier
    , commentCreated   :: UTCTime
    , commentUpdated   :: UTCTime
    , commentContent   :: PandocMarkdown
    , commentReactions :: [Reaction]

    , extCommentReplies :: [Comment]
    }

instance FromJSON Comment where
    parseJSON = withObject "Comment" $ \ o -> Comment
        <$> o .: "index"
        <*> o .: "poster_id"
        <*> o .: "created"
        <*> o .: "updated"
        <*> o .: "content"
        <*> o .: "reactions"
        <*> o .: "replies"

instance ToJSON Comment where
    toJSON c = object
        [ "index"     .= commentIndex c
        , "poster_id" .= commentPoster c
        , "created"   .= commentCreated c
        , "updated"   .= commentUpdated c
        , "content"   .= commentContent c
        , "reactions" .= commentReactions c

        , "replies"   .= extCommentReplies c
        ]
    toEncoding c = pairs
        (  "index"     .= commentIndex c
        <> "poster_id" .= commentPoster c
        <> "created"   .= commentCreated c
        <> "updated"   .= commentUpdated c
        <> "content"   .= commentContent c
        <> "reactions" .= commentReactions c

        <> "replies"   .= extCommentReplies c
        )

data IssueState = IssueOpen | IssueClosed

instance FromJSON IssueState where
    parseJSON = withText "IssueState" $ \case
        "open" -> pure IssueOpen
        "closed" -> pure IssueClosed
        _ -> mzero

renderIssueState :: IssueState -> Text
renderIssueState = \case
    IssueOpen -> "open"
    IssueClosed -> "closed"

instance ToJSON IssueState where
    toJSON = toJSON . renderIssueState
    toEncoding = toEncoding . renderIssueState

data Issue = Issue
    { issueIndex     :: Identifier
    , issuePoster    :: Identifier
    , issueTitle     :: Text
    , issueContent   :: PandocMarkdown
    , issueMilestone :: Maybe Identifier
    , issueState     :: IssueState
    , issueIsLocked  :: Bool
    , issueCreated   :: UTCTime
    , issueUpdated   :: UTCTime
    , issueClosed    :: Maybe UTCTime
    , issueDue       :: Maybe UTCTime
    , issueLabels    :: [Identifier]
    , issueReactions :: [Reaction]
    , issueAssignees :: [Text]

    , extIssueComments :: [Comment]
    }

instance FromJSON Issue where
    parseJSON = withObject "Issue" $ \ o -> Issue
        <$> o .: "index"
        <*> o .: "poster_id"
        <*> o .: "title"
        <*> o .: "content"
        <*> o .:? "milestone"
        <*> o .: "state"
        <*> o .: "is_locked"
        <*> o .: "created"
        <*> o .: "updated"
        <*> o .:? "closed"
        <*> o .:? "due"
        <*> o .: "labels"
        <*> o .: "reactions"
        <*> o .: "assignees"

        <*> o .: "comments"

instance ToJSON Issue where
    toJSON i = object $
        [ "index"     .= issueIndex i
        , "poster_id" .= issuePoster i
        , "title"     .= issueTitle i
        , "content"   .= issueContent i
        , "state"     .= issueState i
        , "is_locked" .= issueIsLocked i
        , "created"   .= issueCreated i
        , "updated"   .= issueUpdated i
        , "labels"    .= issueLabels i
        , "reactions" .= issueReactions i
        , "assignees" .= issueAssignees i

        , "comments"  .= extIssueComments i
        ]
        ++ catMaybes
        [ "milestone" .=?? issueMilestone i
        , "closed"    .=?? issueClosed i
        , "due"       .=?? issueDue i
        ]
    toEncoding i = pairs
        (  "index"     .= issueIndex i
        <> "poster_id" .= issuePoster i
        <> "title"     .= issueTitle i
        <> "content"   .= issueContent i
        <> "milestone" .=? issueMilestone i
        <> "state"     .= issueState i
        <> "is_locked" .= issueIsLocked i
        <> "created"   .= issueCreated i
        <> "updated"   .= issueUpdated i
        <> "closed"    .=? issueClosed i
        <> "due"       .=? issueDue i
        <> "labels"    .= issueLabels i
        <> "reactions" .= issueReactions i
        <> "assignees" .= issueAssignees i

        <> "comments"  .= extIssueComments i
        )

-- Based on the properties of Project
data ExtIssueTracker = IssueTracker
    { issueTrackerIndex       :: Identifier
    , issueTrackerName        :: Text
    , issueTrackerDescription :: Markdown
    , issueTrackerCreated     :: UTCTime
    , issueTrackerUpdated     :: UTCTime
    , issueTrackerIssues      :: [Issue]
    }

instance FromJSON ExtIssueTracker where
    parseJSON = withObject "IssueTracker" $ \ o -> IssueTracker
        <$> o .: "index"
        <*> o .: "name"
        <*> o .: "description"
        <*> o .: "created"
        <*> o .: "updated"
        <*> o .: "issues"

instance ToJSON ExtIssueTracker where
    toJSON it = object
        [ "index"       .= issueTrackerIndex it
        , "name"        .= issueTrackerName it
        , "description" .= issueTrackerDescription it
        , "created"     .= issueTrackerCreated it
        , "updated"     .= issueTrackerUpdated it
        , "issues"      .= issueTrackerIssues it
        ]
    toEncoding it = pairs
        (  "index"       .= issueTrackerIndex it
        <> "name"        .= issueTrackerName it
        <> "description" .= issueTrackerDescription it
        <> "created"     .= issueTrackerCreated it
        <> "updated"     .= issueTrackerUpdated it
        <> "issues"      .= issueTrackerIssues it
        )

data Reaction = Reaction
    { reactionIndex   :: Identifier
    , reactionUser    :: Identifier
    , reactionContent :: Text
    }

instance FromJSON Reaction where
    parseJSON = withObject "Reaction" $ \ o -> Reaction
        <$> o .: "index"
        <*> o .: "user_id"
        <*> o .: "content"

instance ToJSON Reaction where
    toJSON r = object
        [ "index"   .= reactionIndex r
        , "user_id" .= reactionUser r
        , "content" .= reactionContent r
        ]
    toEncoding r = pairs
        (  "index"   .= reactionIndex r
        <> "user_id" .= reactionUser r
        <> "content" .= reactionContent r
        )

data Vcs = Git | Hg | Bazaar | Darcs | Fossil | Svn

renderVcs :: Vcs -> Text
renderVcs = \case
    Git    -> "git"
    Hg     -> "hg"
    Bazaar -> "bazaar"
    Darcs  -> "darcs"
    Fossil -> "fossil"
    Svn    -> "svn"

parseVcs :: Text -> Maybe Vcs
parseVcs = \case
    "git"    -> Just Git
    "hg"     -> Just Hg
    "bazaar" -> Just Bazaar
    "darcs"  -> Just Darcs
    "fossil" -> Just Fossil
    "svn"    -> Just Svn
    _        -> Nothing

instance FromJSON Vcs where
    parseJSON = withText "Vcs" $ maybe mzero pure . parseVcs

instance ToJSON Vcs where
    toJSON = toJSON . renderVcs
    toEncoding = toEncoding . renderVcs

-- Based on the properties of Project and Repository
data ExtRepo = Repo
    { repoIndex       :: Identifier
    , repoName        :: Text
    , repoDescription :: Markdown
    , repoCreated     :: UTCTime
    , repoUpdated     :: UTCTime
    , repoMain        :: Text
    , repoVcs         :: Vcs
    }

instance FromJSON ExtRepo where
    parseJSON = withObject "Repo" $ \ o -> Repo
        <$> o .: "index"
        <*> o .: "name"
        <*> o .: "description"
        <*> o .: "created"
        <*> o .: "updated"
        <*> o .: "default_branch"
        <*> o .: "vcs"

instance ToJSON ExtRepo where
    toJSON it = object
        [ "index"          .= repoIndex it
        , "name"           .= repoName it
        , "description"    .= repoDescription it
        , "created"        .= repoCreated it
        , "updated"        .= repoUpdated it
        , "default_branch" .= repoMain it
        , "vcs"            .= repoVcs it
        ]
    toEncoding it = pairs
        (  "index"          .= repoIndex it
        <> "name"           .= repoName it
        <> "description"    .= repoDescription it
        <> "created"        .= repoCreated it
        <> "updated"        .= repoUpdated it
        <> "default_branch" .= repoMain it
        <> "vcs"            .= repoVcs it
        )
[See repo JSON]