{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module IO.Taskell where
import ClassyPrelude
import Control.Monad.Reader (runReader)
import Data.FileEmbed (embedFile)
import Data.Text.Encoding (decodeUtf8With)
import System.Directory (doesFileExist, getCurrentDirectory)
import Data.Time.Zones (TZ)
import Config (usage, version)
import Data.Taskell.Lists (Lists, analyse, initial)
import IO.Config (Config, general, github, markdown, trello)
import IO.Config.General (filename)
import qualified IO.Config.GitHub as GitHub (token)
import qualified IO.Config.Trello as Trello (token)
import IO.Markdown (MarkdownInfo (MarkdownInfo), parse, serialize)
import qualified IO.HTTP.GitHub as GitHub (GitHubIdentifier, getLists)
import qualified IO.HTTP.Trello as Trello (TrelloBoardID, getLists)
import UI.CLI (PromptYN (PromptYes), promptYN)
data IOInfo = IOInfo
{ ioTZ :: TZ
, ioConfig :: Config
}
type ReaderConfig a = ReaderT IOInfo IO a
data Next
= Output Text
| Error Text
| Load FilePath
Lists
| Exit
parseArgs :: [Text] -> ReaderConfig Next
parseArgs ["-v"] = pure $ Output version
parseArgs ["-h"] = pure $ Output usage
parseArgs ["-t", boardID, file] = loadTrello boardID file
parseArgs ["-g", identifier, file] = loadGitHub identifier file
parseArgs ["-i", file] = fileInfo file
parseArgs [file] = loadFile file
parseArgs [] = (pack . filename . general <$> asks ioConfig) >>= loadFile
parseArgs _ = pure $ Error (unlines ["Invalid options", "", usage])
load :: ReaderConfig Next
load = getArgs >>= parseArgs
colonic :: FilePath -> Text -> Text
colonic path = ((pack path <> ": ") <>)
loadFile :: Text -> ReaderConfig Next
loadFile filepath = do
mPath <- exists filepath
case mPath of
Nothing -> pure Exit
Just path -> either (Error . colonic path) (Load path) <$> readData path
loadRemote :: (token -> FilePath -> ReaderConfig Next) -> token -> Text -> ReaderConfig Next
loadRemote createFn identifier filepath = do
let path = unpack filepath
exists' <- fileExists path
if exists'
then pure $ Error (filepath <> " already exists")
else createFn identifier path
loadTrello :: Trello.TrelloBoardID -> Text -> ReaderConfig Next
loadTrello = loadRemote createTrello
loadGitHub :: GitHub.GitHubIdentifier -> Text -> ReaderConfig Next
loadGitHub = loadRemote createGitHub
fileInfo :: Text -> ReaderConfig Next
fileInfo filepath = do
let path = unpack filepath
exists' <- fileExists path
if exists'
then either (Error . colonic path) (Output . analyse filepath) <$> readData path
else pure $ Error (filepath <> " does not exist")
createRemote ::
(Config -> Maybe token)
-> Text
-> (token -> ReaderT token IO (Either Text Lists))
-> token
-> FilePath
-> ReaderConfig Next
createRemote tokenFn missingToken getFn identifier path = do
config <- asks ioConfig
tz <- asks ioTZ
case tokenFn config of
Nothing -> pure $ Error missingToken
Just token -> do
lists <- lift $ runReaderT (getFn identifier) token
case lists of
Left txt -> pure $ Error txt
Right ls ->
promptCreate path >>=
bool (pure Exit) (Load path ls <$ lift (writeData tz config ls path))
createTrello :: Trello.TrelloBoardID -> FilePath -> ReaderConfig Next
createTrello =
createRemote
(Trello.token . trello)
(decodeUtf8 $(embedFile "templates/trello-token.txt"))
Trello.getLists
createGitHub :: GitHub.GitHubIdentifier -> FilePath -> ReaderConfig Next
createGitHub =
createRemote
(GitHub.token . github)
(decodeUtf8 $(embedFile "templates/github-token.txt"))
GitHub.getLists
exists :: Text -> ReaderConfig (Maybe FilePath)
exists filepath = do
let path = unpack filepath
exists' <- fileExists path
if exists'
then pure $ Just path
else promptCreate path >>= bool (pure Nothing) (Just path <$ createPath path)
fileExists :: FilePath -> ReaderConfig Bool
fileExists path = lift $ doesFileExist path
promptCreate :: FilePath -> ReaderConfig Bool
promptCreate path = do
cwd <- lift $ pack <$> getCurrentDirectory
lift $ promptYN PromptYes $ concat ["Create ", cwd, "/", pack path, "?"]
createPath :: FilePath -> ReaderConfig ()
createPath path = do
config <- asks ioConfig
tz <- asks ioTZ
lift (writeData tz config initial path)
writeData :: TZ -> Config -> Lists -> FilePath -> IO ()
writeData tz config tasks path = void (writeFile path output)
where
output = encodeUtf8 $ runReader (serialize tasks) (MarkdownInfo tz (markdown config))
decodeError :: String -> Maybe Word8 -> Maybe Char
decodeError _ _ = Just '\65533'
readData :: FilePath -> ReaderConfig (Either Text Lists)
readData path =
parse <$> (markdown <$> asks ioConfig) <*> (decodeUtf8With decodeError <$> readFile path)