christian
/
ncdeck
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

add fourmolu config; reformat using fourmolu

This commit is contained in:
Christian Ulrich 2024-05-28 23:46:09 +02:00
parent dfe275eedf
commit 74f96dc563
No known key found for this signature in database
GPG Key ID: 8241BE099775A097
3 changed files with 204 additions and 140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

191
app/Main.hs
View File

@ -2,11 +2,12 @@ module Main where
import Data.Text as T import Data.Text as T
import Data.Text.IO as T import Data.Text.IO as T
-- import Data.Time.Clock -- import Data.Time.Clock
import Data.Time.LocalTime import Data.Time.LocalTime
import NCDeck
import Options.Applicative import Options.Applicative
import System.IO import System.IO
import NCDeck
data Options = Options data Options = Options
{ hostname :: Text { hostname :: Text
@ -17,20 +18,20 @@ data Options = Options
data Command data Command
= ListBoards = ListBoards
| ListStacks | ListStacks
{ boardId :: Word { boardId :: Word
} }
| ListCards | ListCards
{ boardId :: Word { boardId :: Word
, stackId :: Word , stackId :: Word
} }
| CreateCard | CreateCard
{ boardId :: Word { boardId :: Word
, stackId :: Word , stackId :: Word
, title :: Text , title :: Text
, description :: Text , description :: Text
, date :: LocalTime , date :: LocalTime
, weeklyRepeats :: Word , weeklyRepeats :: Word
} }
run :: Options -> IO () run :: Options -> IO ()
run (Options {..}) = do run (Options {..}) = do
@ -51,103 +52,113 @@ run (Options {..}) = do
mapM_ print cards mapM_ print cards
CreateCard {..} -> do CreateCard {..} -> do
createCard hostname username password boardId stackId title description date weeklyRepeats createCard hostname username password boardId stackId title description date weeklyRepeats
parseListStacks :: Parser Command parseListStacks :: Parser Command
parseListStacks = parseListStacks =
ListStacks ListStacks
<$> option auto <$> option
( long "board-id" auto
<> short 'b' ( long "board-id"
<> metavar "BOARD_ID" <> short 'b'
<> help "the id of the kanban board" <> metavar "BOARD_ID"
) <> help "the id of the kanban board"
)
parseListCards :: Parser Command parseListCards :: Parser Command
parseListCards = parseListCards =
ListCards ListCards
<$> option auto <$> option
( long "board-id" auto
<> short 'b' ( long "board-id"
<> metavar "BOARD_ID" <> short 'b'
<> help "the id of the kanban board" <> metavar "BOARD_ID"
) <> help "the id of the kanban board"
<*> option auto )
( long "stack-id" <*> option
<> short 's' auto
<> metavar "STACK_ID" ( long "stack-id"
<> help "the id of the kanban stack" <> short 's'
) <> metavar "STACK_ID"
<> help "the id of the kanban stack"
)
parseCreateCard :: Parser Command parseCreateCard :: Parser Command
parseCreateCard = parseCreateCard =
CreateCard CreateCard
<$> option auto <$> option
( long "board-id" auto
<> short 'b' ( long "board-id"
<> metavar "BOARD_ID" <> short 'b'
<> help "the id of the kanban board" <> metavar "BOARD_ID"
) <> help "the id of the kanban board"
<*> option auto )
( long "stack-id" <*> option
<> short 's' auto
<> metavar "STACK_ID" ( long "stack-id"
<> help "the id of the kanban stack" <> short 's'
) <> metavar "STACK_ID"
<> help "the id of the kanban stack"
)
<*> strOption <*> strOption
( long "title" ( long "title"
<> short 't' <> short 't'
<> metavar "TITLE" <> metavar "TITLE"
<> help "the card's title; the card's date can be included using the placeholders %YY, %MM and %DD" <> help "the card's title; the card's date can be included using the placeholders %YY, %MM and %DD"
) )
<*> strOption <*> strOption
( long "description" ( long "description"
<> short 'd' <> short 'd'
<> metavar "DESC" <> metavar "DESC"
<> value "" <> value ""
<> showDefault <> showDefault
<> help "the card's description" <> help "the card's description"
) )
<*> option auto <*> option
( long "date" -- FIXME: make this optional? auto
<> short 'e' ( long "date" -- FIXME: make this optional?
<> metavar "DATE" <> short 'e'
<> help "the card's date, format: YYYY-MM-DD hh:mm:ss" <> metavar "DATE"
) <> help "the card's date, format: YYYY-MM-DD hh:mm:ss"
<*> option auto )
( long "weekly-repeats" <*> option
<> short 'w' auto
<> metavar "COUNT" ( long "weekly-repeats"
<> value 0 <> short 'w'
<> showDefault <> metavar "COUNT"
<> help "repeat the card weekly COUNT times") <> value 0
<> showDefault
<> help "repeat the card weekly COUNT times"
)
parseOptions :: Parser Options parseOptions :: Parser Options
parseOptions = parseOptions =
Options Options
<$> strOption <$> strOption
( long "hostname" ( long "hostname"
<> short 'o' <> short 'o'
<> metavar "HOSTNAME" <> metavar "HOSTNAME"
<> help "the hostname of the Nextcloud instance" <> help "the hostname of the Nextcloud instance"
) )
<*> strOption <*> strOption
( long "username" ( long "username"
<> short 'u' <> short 'u'
<> metavar "USERNAME" <> metavar "USERNAME"
<> help "the Nextcloud username" <> help "the Nextcloud username"
) )
<*> hsubparser <*> hsubparser
( command "list-boards" (info (pure ListBoards) (progDesc "list all stacks")) ( command "list-boards" (info (pure ListBoards) (progDesc "list all stacks"))
<> command "list-stacks" (info parseListStacks (progDesc "list all stacks")) <> command "list-stacks" (info parseListStacks (progDesc "list all stacks"))
<> command "list-cards" (info parseListCards (progDesc "list all cards")) <> command "list-cards" (info parseListCards (progDesc "list all cards"))
<> command "create-card" (info parseCreateCard (progDesc "create a new card")) <> command "create-card" (info parseCreateCard (progDesc "create a new card"))
) )
main :: IO () main :: IO ()
main = run =<< execParser opts main = run =<< execParser opts
where where
opts = info (parseOptions <**> helper) opts =
( fullDesc info
<> progDesc "Manage a Nextcloud Deck" (parseOptions <**> helper)
<> header "ncdeck - Manage a Nextcloud Deck" ( fullDesc
) <> progDesc "Manage a Nextcloud Deck"
<> header "ncdeck - Manage a Nextcloud Deck"
)

16
fourmolu.yaml Normal file
View File

@ -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

137
src/NCDeck.hs
View File

@ -8,21 +8,23 @@ module NCDeck
, createCard , createCard
) where ) where
import Prelude hiding (id)
import Data.Aeson import Data.Aeson
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import Data.Text qualified as T
import qualified Data.Text.Encoding as T import Data.Text.Encoding qualified as T
import Prelude hiding (id)
-- import Data.Time.Clock -- import Data.Time.Clock
import Data.Time.LocalTime
import Control.Monad
import Control.Monad.IO.Class
import Data.Time.Calendar import Data.Time.Calendar
import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.OrdinalDate
import Data.Time.Clock.POSIX (POSIXTime) import Data.Time.Clock.POSIX (POSIXTime)
import Data.Time.LocalTime
import GHC.Generics import GHC.Generics
import Network.HTTP.Req import Network.HTTP.Req
import Control.Monad
import Control.Monad.IO.Class
data Board = Board data Board = Board
{ id :: Int { id :: Int
@ -30,7 +32,8 @@ data Board = Board
, deletedAt :: POSIXTime , deletedAt :: POSIXTime
, lastModified :: POSIXTime , lastModified :: POSIXTime
, archived :: Bool , archived :: Bool
} deriving Generic }
deriving (Generic)
data Stack = Stack data Stack = Stack
{ id :: Int { id :: Int
@ -39,38 +42,58 @@ data Stack = Stack
, deletedAt :: POSIXTime , deletedAt :: POSIXTime
, lastModified :: POSIXTime , lastModified :: POSIXTime
, cards :: Maybe [Card] , cards :: Maybe [Card]
} deriving Generic }
deriving (Generic)
data Card = Card data Card = Card
{ id :: Int { id :: Int
, title :: Text , title :: Text
, description :: Text , description :: Text
, duedate :: Maybe LocalTime , duedate :: Maybe LocalTime
} deriving Generic }
deriving (Generic)
instance FromJSON Board instance FromJSON Board
instance Show Board where instance Show Board where
show :: Board -> String show :: Board -> String
show (Board {..}) = show (Board {..}) =
T.unpack title <> "\n" <> T.unpack title
"------------------------------------------------------\n" <> <> "\n"
"id:\t\t" <> show id <> "\n" <> <> "------------------------------------------------------\n"
"last modified:\t" <> show lastModified <> "\n" <> <> "id:\t\t"
"deleted at:\t" <> show deletedAt <> "\n" <> <> show id
"archived: \t" <> show archived <> "\n" <> "\n"
<> "last modified:\t"
<> show lastModified
<> "\n"
<> "deleted at:\t"
<> show deletedAt
<> "\n"
<> "archived: \t"
<> show archived
<> "\n"
instance FromJSON Stack instance FromJSON Stack
instance Show Stack where instance Show Stack where
show :: Stack -> String show :: Stack -> String
show (Stack {..}) = show (Stack {..}) =
T.unpack title <> "\n" <> T.unpack title
"------------------------------------------------------\n" <> <> "\n"
"id:\t\t" <> show id <> "\n" <> <> "------------------------------------------------------\n"
"last modified:\t" <> show lastModified <> "\n" <> <> "id:\t\t"
"deleted at:\t" <> show deletedAt <> "\n" <> <> show id
"#cards: \t" <> show (length cards) <> "\n" <> "\n"
<> "last modified:\t"
<> show lastModified
<> "\n"
<> "deleted at:\t"
<> show deletedAt
<> "\n"
<> "#cards: \t"
<> show (length cards)
<> "\n"
instance FromJSON Card instance FromJSON Card
@ -81,26 +104,35 @@ instance Show Card where
desc = T.unpack $ truncateDesc description desc = T.unpack $ truncateDesc description
dd = maybe "None" show duedate dd = maybe "None" show duedate
in in
T.unpack title <> "\n" <> T.unpack title
"----------------------------------------------------\n" <> <> "\n"
"id:\t\t" <> show id <> "\n" <> <> "----------------------------------------------------\n"
"description: \t" <> desc <> "\n" <> <> "id:\t\t"
"due date: \t" <> dd <> "\n" <> show id
<> "\n"
<> "description: \t"
<> desc
<> "\n"
<> "due date: \t"
<> dd
<> "\n"
where where
truncateDesc :: Text -> Text truncateDesc :: Text -> Text
truncateDesc input = truncateDesc input =
let (fstLine, _) = T.break (== '\n') input let
(fstLine, _) = T.break (== '\n') input
in in
if T.length fstLine > 30 if T.length fstLine > 30
then T.take 30 fstLine <> "..." then T.take 30 fstLine <> "..."
else fstLine else fstLine
authHeaders :: Text -> Text -> Option Https authHeaders :: Text -> Text -> Option Https
authHeaders username password = authHeaders username password =
let let
usernameBS = T.encodeUtf8 username usernameBS = T.encodeUtf8 username
passwordBS = T.encodeUtf8 password 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 :: Text -> Url Https
baseUrl hostname = baseUrl hostname =
@ -111,28 +143,32 @@ listBoards hostname username password =
let let
headers = authHeaders username password headers = authHeaders username password
url = baseUrl hostname /: "boards" url = baseUrl hostname /: "boards"
in runReq defaultHttpConfig $ do in
response <- req GET url NoReqBody jsonResponse headers runReq defaultHttpConfig $ do
return $ responseBody response response <- req GET url NoReqBody jsonResponse headers
return $ responseBody response
listStacks :: Text -> Text -> Text -> Word -> IO [Stack] listStacks :: Text -> Text -> Text -> Word -> IO [Stack]
listStacks hostname username password boardId = listStacks hostname username password boardId =
let let
headers = authHeaders username password headers = authHeaders username password
url = baseUrl hostname /: "boards" /: T.pack (show boardId) /: "stacks" url = baseUrl hostname /: "boards" /: T.pack (show boardId) /: "stacks"
in runReq defaultHttpConfig $ do in
response <- req GET url NoReqBody jsonResponse headers runReq defaultHttpConfig $ do
return $ responseBody response response <- req GET url NoReqBody jsonResponse headers
return $ responseBody response
listCards :: Text -> Text -> Text -> Word -> Word -> IO [Card] listCards :: Text -> Text -> Text -> Word -> Word -> IO [Card]
listCards hostname username password boardId stackId = listCards hostname username password boardId stackId =
let let
headers = authHeaders username password headers = authHeaders username password
url = baseUrl hostname /: "boards" /: T.pack (show boardId) /: "stacks" /: T.pack (show stackId) url = baseUrl hostname /: "boards" /: T.pack (show boardId) /: "stacks" /: T.pack (show stackId)
in runReq defaultHttpConfig $ do in
response <- req GET url NoReqBody jsonResponse headers runReq defaultHttpConfig $ do
let stack :: Stack = responseBody response response <- req GET url NoReqBody jsonResponse headers
return $ fromMaybe [] stack.cards let
stack :: Stack = responseBody response
return $ fromMaybe [] stack.cards
createCard :: Text -> Text -> Text -> Word -> Word -> Text -> Text -> LocalTime -> Word -> IO () createCard :: Text -> Text -> Text -> Word -> Word -> Text -> Text -> LocalTime -> Word -> IO ()
createCard hostname username password boardId stackId title description date weeklyRepeats = do 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 (_, dayOfYear) = toOrdinalDate date.localDay
(year, month, day) = toGregorian date.localDay (year, month, day) = toGregorian date.localDay
expandedTitle = expandedTitle =
T.replace "%YY" (T.pack $ show year) $ T.replace "%YY" (T.pack $ show year)
T.replace "%MM" (T.pack $ show month) $ $ T.replace "%MM" (T.pack $ show month)
T.replace "%DD" (T.pack $ show day) title $ T.replace "%DD" (T.pack $ show day) title
body = object body =
[ "title" .= expandedTitle object
, "type" .= ("plain" :: Text) [ "title" .= expandedTitle
, "order" .= dayOfYear , "type" .= ("plain" :: Text)
, "description" .= description , "order" .= dayOfYear
, "duedate" .= localTimeToUTC timezone date , "description" .= description
] , "duedate" .= localTimeToUTC timezone date
]
runReq defaultHttpConfig $ do runReq defaultHttpConfig $ do
_ <- req POST url (ReqBodyJson body) ignoreResponse headers _ <- req POST url (ReqBodyJson body) ignoreResponse headers
when (weeklyRepeats > 0) $ do when (weeklyRepeats > 0) $ do