diff --git a/app/Main.hs b/app/Main.hs index fd2ee9f..bff7b66 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,11 +2,12 @@ module Main where import Data.Text as T import Data.Text.IO as T + -- import Data.Time.Clock import Data.Time.LocalTime +import NCDeck import Options.Applicative import System.IO -import NCDeck data Options = Options { hostname :: Text @@ -17,20 +18,20 @@ data Options = Options data Command = ListBoards | ListStacks - { boardId :: Word - } + { boardId :: Word + } | ListCards - { boardId :: Word - , stackId :: Word - } + { boardId :: Word + , stackId :: Word + } | CreateCard - { boardId :: Word - , stackId :: Word - , title :: Text - , description :: Text - , date :: LocalTime - , weeklyRepeats :: Word - } + { boardId :: Word + , stackId :: Word + , title :: Text + , description :: Text + , date :: LocalTime + , weeklyRepeats :: Word + } run :: Options -> IO () run (Options {..}) = do @@ -51,103 +52,113 @@ run (Options {..}) = do mapM_ print cards CreateCard {..} -> do createCard hostname username password boardId stackId title description date weeklyRepeats - + parseListStacks :: Parser Command parseListStacks = ListStacks - <$> option auto - ( long "board-id" - <> short 'b' - <> metavar "BOARD_ID" - <> help "the id of the kanban board" - ) + <$> option + auto + ( long "board-id" + <> short 'b' + <> metavar "BOARD_ID" + <> help "the id of the kanban board" + ) parseListCards :: Parser Command parseListCards = ListCards - <$> option auto - ( long "board-id" - <> short 'b' - <> metavar "BOARD_ID" - <> help "the id of the kanban board" - ) - <*> option auto - ( long "stack-id" - <> short 's' - <> metavar "STACK_ID" - <> help "the id of the kanban stack" - ) + <$> option + auto + ( long "board-id" + <> short 'b' + <> metavar "BOARD_ID" + <> help "the id of the kanban board" + ) + <*> option + auto + ( long "stack-id" + <> short 's' + <> metavar "STACK_ID" + <> help "the id of the kanban stack" + ) parseCreateCard :: Parser Command parseCreateCard = CreateCard - <$> option auto - ( long "board-id" - <> short 'b' - <> metavar "BOARD_ID" - <> help "the id of the kanban board" - ) - <*> option auto - ( long "stack-id" - <> short 's' - <> metavar "STACK_ID" - <> help "the id of the kanban stack" - ) + <$> option + auto + ( long "board-id" + <> short 'b' + <> metavar "BOARD_ID" + <> help "the id of the kanban board" + ) + <*> option + auto + ( long "stack-id" + <> short 's' + <> metavar "STACK_ID" + <> help "the id of the kanban stack" + ) <*> strOption - ( long "title" - <> short 't' - <> metavar "TITLE" - <> help "the card's title; the card's date can be included using the placeholders %YY, %MM and %DD" - ) + ( long "title" + <> short 't' + <> metavar "TITLE" + <> help "the card's title; the card's date can be included using the placeholders %YY, %MM and %DD" + ) <*> strOption - ( long "description" - <> short 'd' - <> metavar "DESC" - <> value "" - <> showDefault - <> help "the card's description" - ) - <*> option auto - ( long "date" -- FIXME: make this optional? - <> short 'e' - <> metavar "DATE" - <> help "the card's date, format: YYYY-MM-DD hh:mm:ss" - ) - <*> option auto - ( long "weekly-repeats" - <> short 'w' - <> metavar "COUNT" - <> value 0 - <> showDefault - <> help "repeat the card weekly COUNT times") + ( long "description" + <> short 'd' + <> metavar "DESC" + <> value "" + <> showDefault + <> help "the card's description" + ) + <*> option + auto + ( long "date" -- FIXME: make this optional? + <> short 'e' + <> metavar "DATE" + <> help "the card's date, format: YYYY-MM-DD hh:mm:ss" + ) + <*> option + auto + ( long "weekly-repeats" + <> short 'w' + <> metavar "COUNT" + <> value 0 + <> showDefault + <> help "repeat the card weekly COUNT times" + ) parseOptions :: Parser Options parseOptions = Options <$> strOption - ( long "hostname" - <> short 'o' - <> metavar "HOSTNAME" - <> help "the hostname of the Nextcloud instance" - ) + ( long "hostname" + <> short 'o' + <> metavar "HOSTNAME" + <> help "the hostname of the Nextcloud instance" + ) <*> strOption - ( long "username" - <> short 'u' - <> metavar "USERNAME" - <> help "the Nextcloud username" - ) + ( long "username" + <> short 'u' + <> metavar "USERNAME" + <> help "the Nextcloud username" + ) <*> hsubparser - ( command "list-boards" (info (pure ListBoards) (progDesc "list all stacks")) - <> command "list-stacks" (info parseListStacks (progDesc "list all stacks")) - <> command "list-cards" (info parseListCards (progDesc "list all cards")) - <> command "create-card" (info parseCreateCard (progDesc "create a new card")) - ) - + ( command "list-boards" (info (pure ListBoards) (progDesc "list all stacks")) + <> command "list-stacks" (info parseListStacks (progDesc "list all stacks")) + <> command "list-cards" (info parseListCards (progDesc "list all cards")) + <> command "create-card" (info parseCreateCard (progDesc "create a new card")) + ) + main :: IO () main = run =<< execParser opts where - opts = info (parseOptions <**> helper) - ( fullDesc - <> progDesc "Manage a Nextcloud Deck" - <> header "ncdeck - Manage a Nextcloud Deck" - ) + opts = + info + (parseOptions <**> helper) + ( fullDesc + <> progDesc "Manage a Nextcloud Deck" + <> header "ncdeck - Manage a Nextcloud Deck" + ) diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..dcdd219 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,16 @@ +indentation: 2 +column-limit: none +function-arrows: leading +comma-style: leading +import-export-style: leading +indent-wheres: true +record-brace-space: true +newline-between-decls: true +haddock-style: multi-line +haddock-style-module: null +let-style: newline +in-style: left-align +single-constraint-parens: always +single-deriving-parens: always +unicode: never +respectful: true diff --git a/src/NCDeck.hs b/src/NCDeck.hs index 787cf14..55750a9 100644 --- a/src/NCDeck.hs +++ b/src/NCDeck.hs @@ -8,21 +8,23 @@ module NCDeck , createCard ) where -import Prelude hiding (id) import Data.Aeson import Data.Maybe (fromMaybe) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Prelude hiding (id) + -- import Data.Time.Clock -import Data.Time.LocalTime + +import Control.Monad +import Control.Monad.IO.Class import Data.Time.Calendar import Data.Time.Calendar.OrdinalDate import Data.Time.Clock.POSIX (POSIXTime) +import Data.Time.LocalTime import GHC.Generics import Network.HTTP.Req -import Control.Monad -import Control.Monad.IO.Class data Board = Board { id :: Int @@ -30,7 +32,8 @@ data Board = Board , deletedAt :: POSIXTime , lastModified :: POSIXTime , archived :: Bool - } deriving Generic + } + deriving (Generic) data Stack = Stack { id :: Int @@ -39,38 +42,58 @@ data Stack = Stack , deletedAt :: POSIXTime , lastModified :: POSIXTime , cards :: Maybe [Card] - } deriving Generic + } + deriving (Generic) data Card = Card { id :: Int , title :: Text , description :: Text , duedate :: Maybe LocalTime - } deriving Generic + } + deriving (Generic) instance FromJSON Board instance Show Board where show :: Board -> String show (Board {..}) = - T.unpack title <> "\n" <> - "------------------------------------------------------\n" <> - "id:\t\t" <> show id <> "\n" <> - "last modified:\t" <> show lastModified <> "\n" <> - "deleted at:\t" <> show deletedAt <> "\n" <> - "archived: \t" <> show archived <> "\n" + T.unpack title + <> "\n" + <> "------------------------------------------------------\n" + <> "id:\t\t" + <> show id + <> "\n" + <> "last modified:\t" + <> show lastModified + <> "\n" + <> "deleted at:\t" + <> show deletedAt + <> "\n" + <> "archived: \t" + <> show archived + <> "\n" instance FromJSON Stack instance Show Stack where show :: Stack -> String show (Stack {..}) = - T.unpack title <> "\n" <> - "------------------------------------------------------\n" <> - "id:\t\t" <> show id <> "\n" <> - "last modified:\t" <> show lastModified <> "\n" <> - "deleted at:\t" <> show deletedAt <> "\n" <> - "#cards: \t" <> show (length cards) <> "\n" + T.unpack title + <> "\n" + <> "------------------------------------------------------\n" + <> "id:\t\t" + <> show id + <> "\n" + <> "last modified:\t" + <> show lastModified + <> "\n" + <> "deleted at:\t" + <> show deletedAt + <> "\n" + <> "#cards: \t" + <> show (length cards) + <> "\n" instance FromJSON Card @@ -81,26 +104,35 @@ instance Show Card where desc = T.unpack $ truncateDesc description dd = maybe "None" show duedate in - T.unpack title <> "\n" <> - "----------------------------------------------------\n" <> - "id:\t\t" <> show id <> "\n" <> - "description: \t" <> desc <> "\n" <> - "due date: \t" <> dd <> "\n" + T.unpack title + <> "\n" + <> "----------------------------------------------------\n" + <> "id:\t\t" + <> show id + <> "\n" + <> "description: \t" + <> desc + <> "\n" + <> "due date: \t" + <> dd + <> "\n" where truncateDesc :: Text -> Text truncateDesc input = - let (fstLine, _) = T.break (== '\n') input + let + (fstLine, _) = T.break (== '\n') input in if T.length fstLine > 30 - then T.take 30 fstLine <> "..." - else fstLine + then T.take 30 fstLine <> "..." + else fstLine authHeaders :: Text -> Text -> Option Https authHeaders username password = let usernameBS = T.encodeUtf8 username passwordBS = T.encodeUtf8 password - in header "OCS-APIRequest" "true" <> basicAuth usernameBS passwordBS + in + header "OCS-APIRequest" "true" <> basicAuth usernameBS passwordBS baseUrl :: Text -> Url Https baseUrl hostname = @@ -111,28 +143,32 @@ listBoards hostname username password = let headers = authHeaders username password url = baseUrl hostname /: "boards" - in runReq defaultHttpConfig $ do - response <- req GET url NoReqBody jsonResponse headers - return $ responseBody response + in + runReq defaultHttpConfig $ do + response <- req GET url NoReqBody jsonResponse headers + return $ responseBody response listStacks :: Text -> Text -> Text -> Word -> IO [Stack] listStacks hostname username password boardId = let headers = authHeaders username password url = baseUrl hostname /: "boards" /: T.pack (show boardId) /: "stacks" - in runReq defaultHttpConfig $ do - response <- req GET url NoReqBody jsonResponse headers - return $ responseBody response + in + runReq defaultHttpConfig $ do + response <- req GET url NoReqBody jsonResponse headers + return $ responseBody response listCards :: Text -> Text -> Text -> Word -> Word -> IO [Card] listCards hostname username password boardId stackId = let headers = authHeaders username password url = baseUrl hostname /: "boards" /: T.pack (show boardId) /: "stacks" /: T.pack (show stackId) - in runReq defaultHttpConfig $ do - response <- req GET url NoReqBody jsonResponse headers - let stack :: Stack = responseBody response - return $ fromMaybe [] stack.cards + in + runReq defaultHttpConfig $ do + response <- req GET url NoReqBody jsonResponse headers + let + stack :: Stack = responseBody response + return $ fromMaybe [] stack.cards createCard :: Text -> Text -> Text -> Word -> Word -> Text -> Text -> LocalTime -> Word -> IO () createCard hostname username password boardId stackId title description date weeklyRepeats = do @@ -143,16 +179,17 @@ createCard hostname username password boardId stackId title description date wee (_, dayOfYear) = toOrdinalDate date.localDay (year, month, day) = toGregorian date.localDay expandedTitle = - T.replace "%YY" (T.pack $ show year) $ - T.replace "%MM" (T.pack $ show month) $ - T.replace "%DD" (T.pack $ show day) title - body = object - [ "title" .= expandedTitle - , "type" .= ("plain" :: Text) - , "order" .= dayOfYear - , "description" .= description - , "duedate" .= localTimeToUTC timezone date - ] + T.replace "%YY" (T.pack $ show year) + $ T.replace "%MM" (T.pack $ show month) + $ T.replace "%DD" (T.pack $ show day) title + body = + object + [ "title" .= expandedTitle + , "type" .= ("plain" :: Text) + , "order" .= dayOfYear + , "description" .= description + , "duedate" .= localTimeToUTC timezone date + ] runReq defaultHttpConfig $ do _ <- req POST url (ReqBodyJson body) ignoreResponse headers when (weeklyRepeats > 0) $ do