add fourmolu config; reformat using fourmolu
This commit is contained in:
parent
dfe275eedf
commit
74f96dc563
187
app/Main.hs
187
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
|
||||
|
|
@ -55,99 +56,109 @@ run (Options {..}) = do
|
|||
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"
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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
137
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
|
||||
|
|
|
|||
Loading…
Reference in New Issue