module Pinboard ( PinboardM
, runPinboard
, backUpNotes
) where
import Prelude hiding (log, putStrLn)
import Control.Concurrent (threadDelay)
import Control.Monad (when)
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State.Class
import Control.Monad.State.Lazy (StateT, evalStateT)
import Data.Aeson
import Data.Aeson.Types
import Data.ByteString.Char8 as B (pack)
import Data.ByteString.Lazy (ByteString)
import Data.Foldable (for_)
import Data.Set ((\\))
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Text.IO (putStrLn)
import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Traversable (for)
import Data.Version (showVersion)
import Database.SQLite.Simple
import Network.HTTP.Req
import Paths_pinboard_notes_backup (version)
import Types
import Utils (count, friendlyReqError, makeHttpConfig)
-- * Constants
nominalDiffTimeToMicroseconds :: NominalDiffTime -> Int
nominalDiffTimeToMicroseconds = floor . ((1000000 :: Double) *) . realToFrac
-- | The time we should wait between requests to the API. This is measured in seconds.
delayTime :: NominalDiffTime
delayTime = 3
allNotesUrl :: Url 'Https
allNotesUrl = https "api.pinboard.in" /: "v1" /: "notes" /: "list"
noteUrl :: NoteId -> Url 'Https
noteUrl noteId = https "api.pinboard.in" /: "v1" /: "notes" /: (noteIdToText noteId)
-- * SQLite queries
selectUpdatedQuery :: Query
selectUpdatedQuery = "SELECT updated FROM notes WHERE id=?"
deleteQuery :: Query
deleteQuery = "DELETE FROM notes WHERE id=?"
insertQuery :: Query
insertQuery = "INSERT INTO notes (id, title, text, hash, created, updated) VALUES(?, ?, ?, ?, ?, ?)"
-- * Types
data NoteStatus = New | Updated | UpToDate
deriving (Eq)
data PinboardConfig = PinboardConfig { c_token :: String
, c_verbosity :: Verbosity
}
data PinboardState = PinboardState { s_lastSuccess :: UTCTime
}
newtype PinboardM a = Thing {
runPinboardM :: ReaderT PinboardConfig (StateT PinboardState (ExceptT Text IO)) a
} deriving (Applicative, Functor, Monad, MonadIO, MonadReader PinboardConfig,
MonadState PinboardState, MonadError Text)
instance MonadHttp PinboardM where
handleHttpException :: HttpException -> PinboardM a
handleHttpException = throwError . friendlyReqError
getHttpConfig :: PinboardM HttpConfig
getHttpConfig = liftIO makeHttpConfig
runPinboard :: String -> Verbosity -> PinboardM a -> IO (Either Text a)
runPinboard token verbosity k =
let config = PinboardConfig token verbosity
initialState = PinboardState (posixSecondsToUTCTime 0)
in runExceptT (evalStateT (runReaderT (runPinboardM k) config) initialState)
-- * Helper functions
-- | Takes a URL, appends the API token, makes a GET request, and returns the body of the response
-- (if the status code was 2xx) or else Nothing.
performRequest :: Url 'Https -> PinboardM ByteString
performRequest url = do
previousTime <- s_lastSuccess <$> get
currentTime <- liftIO $ getCurrentTime
let timeToWait = delayTime - (diffUTCTime currentTime previousTime)
liftIO $ when (timeToWait > 0) $
threadDelay (nominalDiffTimeToMicroseconds timeToWait)
opts <- reqOptions
response <- req GET url NoReqBody lbsResponse opts
newCurrentTime <- liftIO $ getCurrentTime
put $ PinboardState newCurrentTime
return $ responseBody response
reqOptions :: PinboardM (Option scheme)
reqOptions = do
token <- c_token <$> ask
return $ mconcat [ header "User-Agent" $ B.pack userAgent
, "format" =: ("json" :: Text)
, "auth_token" =: token
]
where userAgent = "pnbackup/" <> showVersion version <> " (+" <> url <> ")"
url = "https://github.com/bdesham/pinboard-notes-backup"
returnOrThrow :: Maybe a -> Text -> PinboardM a
returnOrThrow Nothing err = throwError err
returnOrThrow (Just value) _ = return value
-- * Business logic
backUpNotes :: Connection -> PinboardM ApplicationResult
backUpNotes conn = do
log "Downloading the list of notes..."
notesList <- getNotesList
log "Processing notes (this may take a while)..."
localNoteOnlyIds <- liftIO $ query_ conn "SELECT id FROM notes"
let localNoteIds = (Set.fromList . map fromOnly) localNoteOnlyIds
remoteNoteIds = (Set.fromList . map ns_id) notesList
notesToDelete = localNoteIds \\ remoteNoteIds
numberToDelete = length notesToDelete
for_ notesToDelete $ deleteNote conn
statuses <- for notesList $ handleNote conn
return $ ApplicationResult (count UpToDate statuses)
(count Updated statuses)
(count New statuses)
numberToDelete
handleNote :: Connection -> NoteSignature -> PinboardM NoteStatus
handleNote conn (NoteSignature noteId lastUpdated) = do
lastUpdatedLocally <- liftIO $ query conn selectUpdatedQuery (Only noteId)
case lastUpdatedLocally of
[] -> updateNoteFromServer conn noteId >> return New
[Only lastUpdatedLocally'] ->
if lastUpdatedLocally' < lastUpdated
then updateNoteFromServer conn noteId >> return Updated
else return UpToDate
_ ->
throwError $
"There are multiple notes with the id "
<> noteIdToText noteId
<> ". This should never happen!"
getNote :: NoteId -> PinboardM Note
getNote noteId = do
logVerbose $ "Downloading note " <> (noteIdToText noteId)
body <- performRequest $ noteUrl noteId
let noteObject = decode body :: Maybe Note
returnOrThrow noteObject ("Couldn't retrieve note " <> noteIdToText noteId)
getNotesList :: PinboardM [NoteSignature]
getNotesList = do
body <- performRequest allNotesUrl
let noteSignatures = do -- This "do" block is within the Maybe monad
bodyObject <- decode body :: Maybe Object
notes <- (parseMaybe (\obj -> obj .: "notes") bodyObject) :: Maybe [NoteSignature]
return notes
returnOrThrow noteSignatures "Error getting the list of notes from the server"
deleteNote :: Connection -> NoteId -> PinboardM ()
deleteNote conn noteId = do
logVerbose $ "Deleting note " <> (noteIdToText noteId)
liftIO $ execute conn deleteQuery (Only noteId)
updateNoteFromServer :: Connection -> NoteId -> PinboardM ()
updateNoteFromServer conn noteId = do
note <- getNote noteId
liftIO $ execute conn deleteQuery (Only noteId)
liftIO $ execute conn insertQuery note
-- * Logging
log :: Text -> PinboardM ()
log = liftIO . putStrLn
-- | Prints the given message, but only if the application was run with --verbose.
logVerbose :: Text -> PinboardM ()
logVerbose message = do
verbosity <- c_verbosity <$> ask
when (verbosity == Verbose) $
liftIO $ putStrLn message