espial-0.0.4: src/Model.hs

{-# OPTIONS_GHC -fno-warn-unused-imports #-}

module Model where

import qualified Data.Aeson as A

import Control.Monad.Writer (tell, appEndo, Endo(..))

import Types
import ModelCrypto
import Pretty
import ClassyPrelude.Yesod

import Control.Monad.Trans.Maybe
import Database.Esqueleto hiding ((==.))
import qualified Database.Esqueleto as E
import qualified Data.Time.ISO8601 as TI

-- Physical model

share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateSchema"] [persistLowerCase| 
User json
  name Text
  passwordHash BCrypt
  apiToken Text Maybe
  UniqueUserName name
  deriving Show Eq Typeable Ord

Bookmark json
  userId UserId
  href Text
  description Text
  extended Text
  time UTCTime
  shared Bool
  toRead Bool
  selected Bool
  UniqueUserHref userId href
  deriving Show Eq Typeable Ord

BookmarkTag json
  userId UserId
  tag Text
  bookmarkId BookmarkId
  seq Int
  UniqueUserTagBookmarkId userId tag bookmarkId
  UniqueUserBookmarkIdTagSeq userId bookmarkId tag seq
  deriving Show Eq Typeable Ord
|]

-- UTCTimeStr
  
newtype UTCTimeStr =
  UTCTimeStr { unUTCTimeStr :: UTCTime }
  deriving (Eq, Show, Read, Generic, FromJSON, ToJSON)

instance PathPiece UTCTimeStr where
  toPathPiece (UTCTimeStr u) = pack (TI.formatISO8601Millis u)
  fromPathPiece s = UTCTimeStr <$> TI.parseISO8601 (unpack s)


-- newtypes

newtype UserNameP =
  UserNameP { unUserNameP :: Text }
  deriving (Eq, Show, Read)

newtype TagsP =
  TagsP { unTagsP :: [Text] }
  deriving (Eq, Show, Read)

data SharedP
  = SharedAll
  | SharedPublic
  | SharedPrivate
  deriving (Eq, Show, Read)

data FilterP
  = FilterAll
  | FilterUnread
  | FilterUntagged
  | FilterStarred
  | FilterSingle Int64
  deriving (Eq, Show, Read)

newtype UnreadOnly =
  UnreadOnly { unUnreadOnly :: Bool }
  deriving (Eq, Show, Read)

type Limit = Int64
type Page = Int64

-- Migration

migrateAll :: Migration
migrateAll = migrateSchema >> migrateIndexes

dumpMigration :: DB ()
dumpMigration = printMigration migrateAll

runMigrations :: DB ()
runMigrations = runMigration migrateAll

toMigration :: [Text] -> Migration
toMigration = lift . tell . fmap (False ,)

migrateIndexes :: Migration
migrateIndexes =
  toMigration
    [ "CREATE INDEX IF NOT EXISTS idx_bookmark_time ON bookmark (user_id, time DESC)"
    , "CREATE INDEX IF NOT EXISTS idx_bookmark_tag_bookmark_id ON bookmark_tag (bookmark_id, id, tag, seq)"
    ]


-- User

authenticatePW :: Text -> Text -> DB (Maybe (Entity User))
authenticatePW username password = do
   muser <- getBy (UniqueUserName username)
   case muser of
     Nothing -> pure Nothing
     Just e@(Entity _ user) -> 
        if passwordMatches (userPasswordHash user) (password)
          then pure $ Just e
          else pure $ Nothing

getUserByName :: UserNameP -> DB (Maybe (Entity User))
getUserByName (UserNameP uname) =
  return . headMay =<<
  (select $
   from $ \u -> do
   where_ (u ^. UserName E.==. val uname)
   pure u)

-- bookmarks

bookmarksQuery
  :: Key User
  -> SharedP
  -> FilterP
  -> [Tag]
  -> Limit
  -> Page
  -> DB (Int, [Entity Bookmark])
bookmarksQuery userId sharedp filterp tags limit' page =
  (,) -- total count
  <$> fmap (sum . fmap E.unValue)
      (select $
      from $ \b -> do
      _inner b
      pure $ E.countRows)
      -- paged data
  <*> (select $
       from $ \b -> do
       _inner b
       orderBy [desc (b ^. BookmarkTime)]
       limit limit'
       offset ((page - 1) * limit')
       pure b)
  where
    _inner b = do
      where_ $
        foldMap (\tag -> Endo $ (&&.) 
          (exists $   -- each tag becomes an exists constraint
           from $ \t ->
           where_ (t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId &&.
                  (t ^. BookmarkTagTag E.==. val tag)))) tags
        `appEndo` (b ^. BookmarkUserId E.==. val userId)
      case sharedp of
        SharedAll -> pure ()
        SharedPublic ->  where_ (b ^. BookmarkShared E.==. val True)
        SharedPrivate -> where_ (b ^. BookmarkShared E.==. val False)
      case filterp of
        FilterAll -> pure ()
        FilterUnread ->   where_ (b ^. BookmarkToRead E.==. val True)
        FilterStarred ->  where_ (b ^. BookmarkSelected E.==. val True)
        FilterSingle i -> where_ (b ^. BookmarkId E.==. val (toSqlKey i))
        FilterUntagged -> where_ $ notExists $ from (\t -> where_ $ t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId)

tagsQuery :: [Entity Bookmark] -> DB [Entity BookmarkTag]
tagsQuery bmarks =
  select $
  from $ \t -> do
  where_ (t ^. BookmarkTagBookmarkId `in_` valList (fmap entityKey bmarks))
  orderBy [asc (t ^. BookmarkTagSeq)]
  pure t

withTags :: Key Bookmark -> DB [Entity BookmarkTag]
withTags key = selectList [BookmarkTagBookmarkId ==. key] [Asc BookmarkTagSeq]

-- Bookmark Files

bookmarkEntityToTags :: Entity Bookmark -> [Tag] -> [BookmarkTag]
bookmarkEntityToTags (Entity {entityKey = bookmarkId
                             ,entityVal = Bookmark {..}}) tags =
  fmap
    (\(i, tag) -> BookmarkTag bookmarkUserId tag bookmarkId i)
    (zip [1 ..] tags)


postToBookmark :: UserId -> Post -> Bookmark
postToBookmark user Post {..} =
  Bookmark user postHref postDescription postExtended postTime postShared postToRead False


insertFileBookmarks :: Key User -> FilePath -> DB ()
insertFileBookmarks userId bookmarkFile = do
  posts' <- liftIO $ readBookmarkFileJson bookmarkFile
  case posts' of
      Left e -> print e
      Right posts -> do
        let bookmarks = fmap (postToBookmark userId) posts
        mbookmarkIds <- mapM insertUnique bookmarks 

        let bookmarkTags =
              concatMap (uncurry bookmarkEntityToTags) $
              catMaybes $
              zipWith3 (\mk v p -> map (\k -> (Entity k v, postTags p)) mk)
                mbookmarkIds
                bookmarks
                posts
        void $ mapM insertUnique bookmarkTags
  where
    readBookmarkFileJson :: MonadIO m => FilePath -> m (Either String [Post])
    readBookmarkFileJson fpath = pure . A.eitherDecode' . fromStrict =<< readFile fpath

type Tag = Text

data Post = Post
  { postHref :: !Text
  , postDescription :: !Text
  , postExtended :: !Text
  , postTime :: !UTCTime
  , postShared :: !Bool
  , postToRead :: !Bool
  , postTags :: [Tag]
  } deriving (Show, Eq, Ord, Typeable)

instance FromJSON Post where
  parseJSON (Object o) =
    Post <$> o .: "href" <*> o .: "description" <*> o .: "extended" <*>
    o .: "time" <*>
    (boolFromYesNo <$> o .: "shared") <*>
    (boolFromYesNo <$> o .: "toread") <*>
    (words <$> o .: "tags")
  parseJSON _ = fail "bad parse"

instance ToJSON Post where
  toJSON Post {..} =
    object
      [ "href" .= toJSON postHref
      , "description" .= toJSON postDescription
      , "extended" .= toJSON postExtended
      , "time" .= toJSON postTime
      , "shared" .= boolToYesNo postShared
      , "toread" .= boolToYesNo postToRead
      , "tags" .= unwords postTags
      ]

boolFromYesNo :: Text -> Bool
boolFromYesNo "yes" = True
boolFromYesNo _ = False

boolToYesNo :: Bool -> Text
boolToYesNo True = "yes"
boolToYesNo _ = "no"


-- BookmarkForm

data BookmarkForm = BookmarkForm
  { _url :: Text
  , _title :: Maybe Text
  , _description :: Maybe Textarea
  , _tags :: Maybe Text
  , _private :: Maybe Bool
  , _toread :: Maybe Bool
  , _bid :: Maybe Int64
  , _selected :: Maybe Bool
  , _time :: Maybe UTCTimeStr
  } deriving (Show, Eq, Read, Generic)

instance FromJSON BookmarkForm where parseJSON = A.genericParseJSON gBookmarkFormOptions
instance ToJSON BookmarkForm where toJSON = A.genericToJSON gBookmarkFormOptions

gBookmarkFormOptions :: A.Options
gBookmarkFormOptions = A.defaultOptions { A.fieldLabelModifier = drop 1 } 

toBookmarkFormList :: [Entity Bookmark] -> [Entity BookmarkTag] -> [BookmarkForm]
toBookmarkFormList bs as = do
  b <- bs
  let bid = E.entityKey b
  let btags = fmap bookmarkTagTag $ filter ((==) bid . bookmarkTagBookmarkId) (fmap E.entityVal as)
  pure $ toBookmarkForm b btags

toBookmarkForm :: Entity Bookmark -> [Text] -> BookmarkForm
toBookmarkForm (Entity bid Bookmark {..}) tags =
  BookmarkForm
  { _url = bookmarkHref
  , _title = Just bookmarkDescription
  , _description = Just $ Textarea $ bookmarkExtended
  , _tags = Just $ unwords $ tags
  , _private = Just $ not bookmarkShared
  , _toread = Just $ bookmarkToRead
  , _bid = Just $ fromSqlKey bid
  , _selected = Just bookmarkSelected
  , _time = Just $ UTCTimeStr $ bookmarkTime
  }
  
_toBookmarkDefs :: (Entity Bookmark, [Entity BookmarkTag]) -> BookmarkForm
_toBookmarkDefs (Entity bid Bookmark {..}, tags) =
  BookmarkForm
  { _url = bookmarkHref
  , _title = Just bookmarkDescription
  , _description = Just $ Textarea $ bookmarkExtended
  , _tags = Just $ unwords $ fmap (bookmarkTagTag . entityVal) tags
  , _private = Just $ not bookmarkShared
  , _toread = Just $ bookmarkToRead
  , _bid = Just $ fromSqlKey $ bid
  , _selected = Just $ bookmarkSelected
  , _time = Just $ UTCTimeStr $ bookmarkTime
  }

_toBookmark :: UserId -> UTCTime -> BookmarkForm -> Bookmark
_toBookmark userId time BookmarkForm {..} =
  Bookmark userId _url
    (fromMaybe "" _title)
    (maybe "" unTextarea _description)
    (fromMaybe time (fmap unUTCTimeStr _time))
    (maybe True not _private)
    (fromMaybe False _toread)
    (fromMaybe False _selected)

fetchBookmarkByUrl :: Key User -> Maybe Text -> DB (Maybe (Entity Bookmark, [Entity BookmarkTag]))
fetchBookmarkByUrl userId murl = runMaybeT $ do
  bmark <- MaybeT . getBy . UniqueUserHref userId =<< (MaybeT $ pure murl)
  btags <- lift $ withTags (entityKey bmark)
  pure (bmark, btags)

data UpsertResult = Created | Updated

upsertBookmark:: Maybe (Key Bookmark) -> Bookmark -> [Text] -> DB (UpsertResult, Key Bookmark)
upsertBookmark mbid bmark@Bookmark{..} tags = do
  res <- case mbid of
    Just bid -> do
      get bid >>= \case 
        Just _ -> replaceBookmark bid
        _ -> fail "not found"
    Nothing -> do
      getBy (UniqueUserHref bookmarkUserId bookmarkHref) >>= \case
        Just (Entity bid _) -> replaceBookmark bid
        _ -> (Created,) <$> insert bmark
  insertTags bookmarkUserId (snd res)
  pure res
  where 
    replaceBookmark bid = do
      replace bid bmark
      deleteTags bid
      pure (Updated, bid)
    deleteTags bid =
      deleteWhere [BookmarkTagBookmarkId ==. bid]
    insertTags userId bid' =
      forM_ (zip [1 ..] tags) $
      \(i, tag) -> void $ insert $ BookmarkTag userId tag bid' i