[#22] Add contacts

CHANGELOG.md

@@ -9,6 +9,7 @@ and this project adheres to
 - Track issue content
 - Add wiki notes
 - Add completion installation instruction
+- Add contacts
 
 ## [0.6] - 2018-08-07
 ### Added

ff-core/lib/FF.hs

@@ -8,13 +8,16 @@
 {-# LANGUAGE ViewPatterns #-}
 
 module FF
-    ( cmdDelete
+    ( cmdDeleteNote
+    , cmdDeleteContact
     , cmdDone
     , cmdEdit
-    , cmdNew
+    , cmdNewNote
+    , cmdNewContact
     , cmdPostpone
     , cmdSearch
     , cmdUnarchive
+    , getContactSamples
     , getSamples
     , getUtcToday
     , loadActiveNotes
@@ -58,26 +61,37 @@ import           FF.Config (ConfigUI (..))
 import           FF.Options (Edit (..), New (..))
 import           FF.Storage (Document (..), MonadStorage, Storage, create,
                              listDocuments, load, modify)
-import           FF.Types (Limit, ModeMap, Note (..), NoteId, NoteView (..),
-                           Sample (..), Status (..), Tracked, noteView,
-                           rgaFromText, rgaToText, singletonTaskModeMap)
+import           FF.Types (Contact (..), ContactId, ContactSample,
+                           ContactView (..), Limit, ModeMap, Note (..), NoteId,
+                           NoteSample, NoteStatus (..), NoteView (..),
+                           Sample (..), Status (..), Tracked, contactView,
+                           noteView, rgaFromText, rgaToText,
+                           singletonTaskModeMap)
 
-getSamples
-    :: MonadStorage m
-    => ConfigUI
-    -> Maybe Limit
-    -> Day  -- ^ today
-    -> m (ModeMap Sample)
-getSamples = getSamplesWith $ const True
+loadAllContacts :: (MonadStorage m) => m [ContactView]
+loadAllContacts = do
+    docs      <- listDocuments
+    mcontacts <- for docs load
+    pure
+        [ contactView contactId value
+        | (contactId, Right Document{value}) <- zip docs mcontacts
+        ]
 
-cmdSearch
-    :: Text
-    -> Maybe Limit
-    -> Day  -- ^ today
-    -> Storage (ModeMap Sample)
-cmdSearch substr = getSamplesWith
-    (Text.isInfixOf (Text.toCaseFold substr) . Text.toCaseFold)
-    ConfigUI {shuffle = False}
+loadActiveContacts :: MonadStorage m => m [ContactView]
+loadActiveContacts =
+    filter (\ContactView { contactViewStatus } -> contactViewStatus == Active) <$> loadAllContacts
+
+getContactSamples :: MonadStorage m => m ContactSample
+getContactSamples = getContactSamplesWith $ const True
+
+getContactSamplesWith
+    :: MonadStorage m
+    => (Text -> Bool)  -- ^ predicate to filter contacts by text
+    -> m ContactSample
+getContactSamplesWith predicate = do
+    activeContacts <- loadActiveContacts
+    pure . (\ys -> Sample ys $ genericLength ys) .
+        filter (predicate . contactViewName) $ activeContacts
 
 loadAllNotes :: MonadStorage m => m [NoteView]
 loadAllNotes = do
@@ -100,15 +114,23 @@ loadTrackedNotes = do
 
 loadActiveNotes :: MonadStorage m => m [NoteView]
 loadActiveNotes =
-    filter (\NoteView { status } -> status == Active) <$> loadAllNotes
+    filter (\NoteView { status } -> status == TaskStatus Active) <$> loadAllNotes
+
+getSamples
+    :: MonadStorage m
+    => ConfigUI
+    -> Maybe Limit
+    -> Day  -- ^ today
+    -> m (ModeMap NoteSample)
+getSamples = getSamplesWith $ const True
 
 getSamplesWith
     :: MonadStorage m
     => (Text -> Bool)  -- ^ predicate to filter notes by text
     -> ConfigUI
     -> Maybe Limit
     -> Day             -- ^ today
-    -> m (ModeMap Sample)
+    -> m (ModeMap NoteSample)
 getSamplesWith predicate ConfigUI { shuffle } limit today = do
     activeNotes <- loadActiveNotes
     -- in sorting by nid no business-logic is involved,
@@ -131,7 +153,7 @@ shuffleItems gen = (`evalState` gen) . traverse shuf
 splitModes :: Day -> [NoteView] -> ModeMap [NoteView]
 splitModes today = Map.unionsWith (<>) . fmap (singletonTaskModeMap today)
 
-takeSamples :: Maybe Limit -> ModeMap [NoteView] -> ModeMap Sample
+takeSamples :: Maybe Limit -> ModeMap [NoteView] -> ModeMap NoteSample
 takeSamples Nothing = fmap mkSample
   where
     mkSample ys = Sample ys $ genericLength ys
@@ -169,12 +191,11 @@ updateTrackedNotes nvNews = do
     mapM_ (updateTrackedNote oldNotes) nvNews
 
 -- | Native 'Note' smart constructor
-newNote :: Clock m => Status -> Text -> Day -> Maybe Day -> m Note
+newNote :: Clock m => NoteStatus -> Text -> Day -> Maybe Day -> m Note
 newNote status text start end = newNote' status text start end Nothing
 
 -- | Generic 'Note' smart constructor
-newNote'
-    :: Clock m => Status -> Text -> Day -> Maybe Day -> Maybe Tracked -> m Note
+newNote' :: Clock m => NoteStatus -> Text -> Day -> Maybe Day -> Maybe Tracked -> m Note
 newNote' status text start end tracked = do
     noteStatus <- LWW.initialize status
     noteText   <- rgaFromText text
@@ -183,8 +204,8 @@ newNote' status text start end tracked = do
     let noteTracked = Max.initial <$> tracked
     pure Note{..}
 
-cmdNew :: MonadStorage m => New -> Day -> m NoteView
-cmdNew New { newText, newStart, newEnd, newWiki } today = do
+cmdNewNote :: MonadStorage m => New -> Day -> m NoteView
+cmdNewNote New { newText, newStart, newEnd, newWiki } today = do
     let newStart' = fromMaybe today newStart
     case newEnd of
         Just end -> assertStartBeforeEnd newStart' end
@@ -193,15 +214,46 @@ cmdNew New { newText, newStart, newEnd, newWiki } today = do
         if newWiki then case newEnd of
             Nothing -> pure (Wiki, Nothing)
             Just _  -> fail "Wiki note has no end date."
-        else pure (Active, newEnd)
+        else pure (TaskStatus Active, newEnd)
     note <- newNote status newText newStart' end
     nid  <- create note
     pure $ noteView nid note
 
-cmdDelete :: NoteId -> Storage NoteView
-cmdDelete nid = modifyAndView nid $ \note@Note {..} -> do
+-- | Generic 'Contact' smart constructor
+newContact' :: Clock m => Status -> Text -> m Contact
+newContact' st name = do
+    contactStatus <- LWW.initialize st
+    contactName   <- rgaFromText name
+    pure Contact{..}
+
+cmdNewContact :: MonadStorage m => Text -> m ContactView
+cmdNewContact name = do
+    contact <- newContact' Active name
+    cid  <- create contact
+    pure $ contactView cid contact
+
+cmdDeleteContact :: ContactId -> Storage ContactView
+cmdDeleteContact cid = modifyAndViewContact cid $ \contact@Contact {..} -> do
+    contactStatus' <- LWW.assign Deleted contactStatus
+    contactName'   <- rgaEditText Text.empty contactName
+    pure contact
+        { contactStatus = contactStatus'
+        , contactName   = contactName'
+        }
+
+cmdSearch
+    :: Text
+    -> Maybe Limit
+    -> Day  -- ^ today
+    -> Storage (ModeMap NoteSample)
+cmdSearch substr = getSamplesWith
+    (Text.isInfixOf (Text.toCaseFold substr) . Text.toCaseFold)
+    ConfigUI {shuffle = False}
+
+cmdDeleteNote :: NoteId -> Storage NoteView
+cmdDeleteNote nid = modifyAndView nid $ \note@Note {..} -> do
     assertNoteIsNative note
-    noteStatus' <- LWW.assign Deleted noteStatus
+    noteStatus' <- LWW.assign (TaskStatus Deleted) noteStatus
     noteText'   <- rgaEditText Text.empty noteText
     noteStart'  <- LWW.assign (fromGregorian 0 1 1) noteStart
     noteEnd'    <- LWW.assign Nothing noteEnd
@@ -214,12 +266,12 @@ cmdDelete nid = modifyAndView nid $ \note@Note {..} -> do
 cmdDone :: NoteId -> Storage NoteView
 cmdDone nid = modifyAndView nid $ \note@Note { noteStatus } -> do
     assertNoteIsNative note
-    noteStatus' <- LWW.assign Archived noteStatus
+    noteStatus' <- LWW.assign (TaskStatus Archived) noteStatus
     pure note { noteStatus = noteStatus' }
 
 cmdUnarchive :: NoteId -> Storage NoteView
 cmdUnarchive nid = modifyAndView nid $ \note@Note { noteStatus } -> do
-    noteStatus' <- LWW.assign Active noteStatus
+    noteStatus' <- LWW.assign (TaskStatus Active) noteStatus
     pure note { noteStatus = noteStatus' }
 
 cmdEdit :: Edit -> Storage NoteView
@@ -278,6 +330,9 @@ cmdPostpone nid = modifyAndView nid $ \note@Note { noteStart, noteEnd } -> do
 modifyAndView :: NoteId -> (Note -> Storage Note) -> Storage NoteView
 modifyAndView nid f = noteView nid <$> modify nid f
 
+modifyAndViewContact :: ContactId -> (Contact -> Storage Contact) -> Storage ContactView
+modifyAndViewContact cid f = contactView cid <$> modify cid f
+
 getUtcToday :: MonadIO io => io Day
 getUtcToday = liftIO $ utctDay <$> getCurrentTime
 

ff-core/lib/FF/Github.hs

@@ -7,7 +7,8 @@ module FF.Github
     ( getIssueViews
     , getOpenIssueSamples
     , sampleMap
-    ) where
+    )
+where
 
 import           Control.Error (failWith)
 import           Control.Monad.Except (ExceptT (..), liftIO, throwError,
@@ -27,8 +28,8 @@ import           GitHub.Endpoints.Issues (issuesForRepoR)
 import           System.Process (readProcess)
 
 import           FF (splitModes, takeSamples)
-import           FF.Types (Limit, ModeMap, NoteView (..), Sample (..),
-                           Status (..), Tracked (..))
+import           FF.Types (Limit, ModeMap, NoteSample, NoteStatus (..),
+                           NoteView (..), Status (..), Tracked (..))
 
 getIssues
     :: Maybe Text
@@ -38,60 +39,61 @@ getIssues
 getIssues mAddress mlimit issueState = do
     address <- case mAddress of
         Just address -> pure address
-        Nothing -> do
-            packed <- liftIO $ Text.pack <$>
-                readProcess "git" ["remote", "get-url", "--push", "origin"] ""
-            failWith "Sorry, only github repository expected." $
-                Text.stripPrefix "https://github.com/" packed
+        Nothing      -> do
+            packed <- liftIO $ Text.pack <$> readProcess
+                "git"
+                ["remote", "get-url", "--push", "origin"]
+                ""
+            failWith "Sorry, only github repository expected."
+                $   Text.stripPrefix "https://github.com/" packed
                 >>= Text.stripSuffix ".git\n"
     (owner, repo) <- case Text.splitOn "/" address of
         [owner, repo] | not $ Text.null owner, not $ Text.null repo ->
             pure (owner, repo)
-        _ -> throwError $
-            "Something is wrong with " <> address <>
-            ". Please, check correctness of input. Right format is OWNER/REPO"
-    response <- withExceptT (Text.pack . show) $ ExceptT $
-        executeRequest' $ issuesForRepoR
-            (mkOwnerName owner)
-            (mkRepoName repo)
-            issueState
-            (maybe FetchAll (FetchAtLeast . fromIntegral) mlimit)
+        _ ->
+            throwError
+                $ "Something is wrong with "
+                <> address
+                <> ". Please, check correctness of input. Right format is OWNER/REPO"
+    response <-
+        withExceptT (Text.pack . show)
+        $ ExceptT
+        $ executeRequest'
+        $ issuesForRepoR
+              (mkOwnerName owner)
+              (mkRepoName repo)
+              issueState
+              (maybe FetchAll (FetchAtLeast . fromIntegral) mlimit)
     pure (address, response)
 
 getOpenIssueSamples
-    :: Maybe Text
-    -> Maybe Limit
-    -> Day
-    -> ExceptT Text IO (ModeMap Sample)
+    :: Maybe Text -> Maybe Limit -> Day -> ExceptT Text IO (ModeMap NoteSample)
 getOpenIssueSamples mAddress mlimit today = do
     (address, issues) <- getIssues mAddress mlimit stateOpen
     pure $ sampleMap address mlimit today issues
 
-getIssueViews
-    :: Maybe Text
-    -> Maybe Limit
-    -> ExceptT Text IO [NoteView]
+getIssueViews :: Maybe Text -> Maybe Limit -> ExceptT Text IO [NoteView]
 getIssueViews mAddress mlimit = do
     (address, issues) <- getIssues mAddress mlimit stateAll
     pure $ noteViewList address mlimit issues
 
 sampleMap
-    :: Foldable t => Text -> Maybe Limit -> Day -> t Issue -> ModeMap Sample
+    :: Foldable t => Text -> Maybe Limit -> Day -> t Issue -> ModeMap NoteSample
 sampleMap address mlimit today issues =
     takeSamples mlimit
-    . splitModes today
-    . map (issueToNoteView address)
-    . maybe id (take . fromIntegral) mlimit
-    $ toList issues
+        . splitModes today
+        . map (issueToNoteView address)
+        . maybe id (take . fromIntegral) mlimit
+        $ toList issues
 
 noteViewList :: Foldable t => Text -> Maybe Limit -> t Issue -> [NoteView]
 noteViewList address mlimit issues =
     map (issueToNoteView address)
-    . maybe id (take . fromIntegral) mlimit
-    $ toList issues
+        . maybe id (take . fromIntegral) mlimit
+        $ toList issues
 
 issueToNoteView :: Text -> Issue -> NoteView
-issueToNoteView address Issue{..} = NoteView
+issueToNoteView address Issue {..} = NoteView
     { nid     = Nothing
     , status  = toStatus issueState
     , text    = issueTitle <> body
@@ -106,18 +108,19 @@ issueToNoteView address Issue{..} = NoteView
     }
   where
     trackedExternalId = Text.pack $ show issueNumber
-    trackedUrl = case issueHtmlUrl of
+    trackedUrl        = case issueHtmlUrl of
         Just (URL url) -> url
-        Nothing        ->
+        Nothing ->
             "https://github.com/" <> address <> "/issues/" <> trackedExternalId
     end = case issueMilestone of
-        Just Milestone{milestoneDueOn = Just UTCTime{utctDay}} -> Just utctDay
-        _                                                      -> Nothing
+        Just Milestone { milestoneDueOn = Just UTCTime { utctDay } } ->
+            Just utctDay
+        _ -> Nothing
     body = case issueBody of
         Nothing -> ""
         Just b  -> if Text.null b then "" else "\n\n" <> b
 
-toStatus :: IssueState -> Status
+toStatus :: IssueState -> NoteStatus
 toStatus = \case
-    StateOpen   -> Active
-    StateClosed -> Archived
+    StateOpen   -> TaskStatus Active
+    StateClosed -> TaskStatus Archived