chore(users/Profpatsch): park mailbox-org
I should probably remove the default.nix files in these as well so they don’t get built on CI. Change-Id: I09764f2ee198ab4016a1649f1675f7c45d207b09 Reviewed-on: https://cl.tvl.fyi/c/depot/+/12580 Tested-by: BuildkiteCI Reviewed-by: Profpatsch <mail@profpatsch.de>
This commit is contained in:
Profpatsch
parent
2d6e98f8a4
commit
fb4b8ab5ec
7 changed files with 0 additions and 5 deletions
523
users/Profpatsch/parked/mailbox-org/MailboxOrg.hs
Normal file
523
users/Profpatsch/parked/mailbox-org/MailboxOrg.hs
Normal file
|
|
@ -0,0 +1,523 @@
|
|||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE GHC2021 #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE NoFieldSelectors #-}
|
||||
{-# OPTIONS_GHC -Wall #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Aeson (parseErrorTree)
|
||||
import AesonQQ (aesonQQ)
|
||||
import ArglibNetencode
|
||||
import Control.Exception (try)
|
||||
import Control.Monad (replicateM)
|
||||
import Data.Aeson qualified as Json
|
||||
import Data.Aeson.BetterErrors qualified as Json
|
||||
import Data.Aeson.KeyMap qualified as KeyMap
|
||||
import Data.ByteString qualified as ByteString
|
||||
import Data.ByteString.Lazy qualified as Lazy
|
||||
import Data.Char qualified as Char
|
||||
import "pa-error-tree" Data.Error.Tree
|
||||
import Data.Functor.Compose
|
||||
import Data.List qualified as List
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Data.Text qualified as Text
|
||||
import ExecHelpers
|
||||
import Label
|
||||
import Netencode qualified
|
||||
import Netencode.Parse qualified as NetParse
|
||||
import Network.HTTP.Conduit qualified as Client
|
||||
import Network.HTTP.Simple qualified as Client
|
||||
import PossehlAnalyticsPrelude
|
||||
import Pretty
|
||||
import System.Directory qualified as File
|
||||
import System.Environment qualified as Env
|
||||
import System.Exit (ExitCode (ExitFailure, ExitSuccess))
|
||||
import System.Exit qualified as Exit
|
||||
import System.FilePath ((</>))
|
||||
import System.Process.Typed qualified as Process
|
||||
import System.Random qualified as Random
|
||||
import System.Random.Stateful qualified as Random
|
||||
import Prelude hiding (log)
|
||||
|
||||
secret :: Tools -> IO (T2 "email" ByteString "password" ByteString)
|
||||
secret tools = do
|
||||
T2
|
||||
(label @"email" "mail@profpatsch.de")
|
||||
<$> (label @"password" <$> fromPass "email/mailbox.org")
|
||||
where
|
||||
fromPass name =
|
||||
tools.pass & runToolExpect0 [name]
|
||||
|
||||
progName :: CurrentProgramName
|
||||
progName = "mailbox-org"
|
||||
|
||||
log :: Error -> IO ()
|
||||
log err = do
|
||||
putStderrLn (errorContext progName.unCurrentProgramName err & prettyError)
|
||||
|
||||
data Tools = Tools
|
||||
{ pass :: Tool
|
||||
}
|
||||
deriving stock (Show)
|
||||
|
||||
newtype Tool = Tool {unTool :: FilePath}
|
||||
deriving stock (Show)
|
||||
|
||||
parseTools :: Applicative m => (Text -> m (Either Error Tool)) -> m (Either ErrorTree Tools)
|
||||
parseTools getTool = do
|
||||
let parser =
|
||||
( do
|
||||
pass <- get "pass"
|
||||
pure Tools {..}
|
||||
)
|
||||
parser & finalize
|
||||
where
|
||||
get name = name & getTool <&> eitherToListValidation & Compose
|
||||
finalize p =
|
||||
p.getCompose
|
||||
<&> first (errorTree "Error reading tools")
|
||||
<&> validationToEither
|
||||
|
||||
main :: IO ()
|
||||
main =
|
||||
arglibNetencode progName Nothing
|
||||
>>= parseToolsArglib
|
||||
>>= secret
|
||||
>>= run applyFilters
|
||||
|
||||
run ::
|
||||
( HasField "email" dat ByteString,
|
||||
HasField "password" dat ByteString
|
||||
) =>
|
||||
(Session -> IO ()) ->
|
||||
dat ->
|
||||
IO ()
|
||||
run act loginData = do
|
||||
session <- login loginData
|
||||
act session
|
||||
|
||||
listFilterConfig :: Session -> IO ()
|
||||
listFilterConfig session = do
|
||||
mailfilter
|
||||
session
|
||||
"config"
|
||||
mempty
|
||||
(Json.key "data" Json.asObject)
|
||||
()
|
||||
>>= printPretty
|
||||
|
||||
applyFilterRule ::
|
||||
(HasField "folderId" dat Text) =>
|
||||
dat ->
|
||||
Session ->
|
||||
IO ()
|
||||
applyFilterRule dat session = do
|
||||
mailfilter
|
||||
session
|
||||
"apply"
|
||||
( T2
|
||||
(label @"extraQueryParams" [("folderId", Just (dat.folderId & textToBytesUtf8))])
|
||||
mempty
|
||||
)
|
||||
(Json.key "data" Json.asArray >> pure ())
|
||||
(Json.Object mempty)
|
||||
|
||||
data FilterRule = FilterRule
|
||||
{ actioncmds :: NonEmpty Json.Object,
|
||||
test :: NonEmpty Json.Object
|
||||
}
|
||||
|
||||
data MailfilterList = MailfilterList
|
||||
{ id_ :: Json.Value,
|
||||
rulename :: Text
|
||||
}
|
||||
deriving stock (Show, Eq)
|
||||
|
||||
simpleRule ::
|
||||
( HasField "rulename" r Text,
|
||||
HasField "id" r Natural,
|
||||
HasField "emailContains" r Text,
|
||||
HasField "subjectStartsWith" r Text
|
||||
) =>
|
||||
r ->
|
||||
Json.Value
|
||||
simpleRule dat = do
|
||||
[aesonQQ|{
|
||||
"id": |dat.id & enc @Natural|,
|
||||
"position": 3,
|
||||
"rulename": |dat.rulename & enc @Text|,
|
||||
"active": true,
|
||||
"flags": [],
|
||||
"test": {
|
||||
"id": "allof",
|
||||
"tests": [
|
||||
{
|
||||
"id": "from",
|
||||
"comparison": "contains",
|
||||
"values": [
|
||||
|dat.emailContains & enc @Text|
|
||||
]
|
||||
},
|
||||
{
|
||||
"id": "subject",
|
||||
"comparison": "startswith",
|
||||
"values": [
|
||||
|dat.subjectStartsWith & enc @Text|
|
||||
]
|
||||
}
|
||||
]
|
||||
},
|
||||
"actioncmds": [
|
||||
{
|
||||
"id": "move",
|
||||
"into": "default0/Archive"
|
||||
},
|
||||
{
|
||||
"id": "stop"
|
||||
}
|
||||
]
|
||||
}|]
|
||||
where
|
||||
enc :: forall a. Json.ToJSON a => a -> Lazy.ByteString
|
||||
enc val = val & Json.toJSON & Json.encode
|
||||
|
||||
applyFilters :: Session -> IO ()
|
||||
applyFilters session = do
|
||||
filters <-
|
||||
mailfilter
|
||||
session
|
||||
"list"
|
||||
mempty
|
||||
( Json.key "data" $ do
|
||||
( Json.eachInArray $ asDat @"mailfilter" $ do
|
||||
id_ <- Json.key "id" Json.asValue
|
||||
rulename <- Json.key "rulename" Json.asText
|
||||
pure MailfilterList {..}
|
||||
)
|
||||
<&> mapFromListOn (\dat -> getLabel @"rulename" dat.parsed)
|
||||
)
|
||||
([] :: [()])
|
||||
let goal = Map.fromList [(label @"rulename" "another", 32 :: Integer), (label @"rulename" "xyz", 23)]
|
||||
let actions = declarativeUpdate goal filters
|
||||
log [fmt|To * create: {actions.toCreate & Map.keys & show}, * update: {actions.toUpdate & Map.keys & show}, * delete: {actions.toDelete & Map.keys & show}|]
|
||||
|
||||
-- where
|
||||
-- filters
|
||||
-- & Map.elems
|
||||
-- & traverse_
|
||||
-- ( updateIfDifferent
|
||||
-- session
|
||||
-- ( \el ->
|
||||
-- pure $
|
||||
-- el.original.mailfilter
|
||||
-- & KeyMap.insert "active" (Json.Bool False)
|
||||
-- )
|
||||
-- (pure ())
|
||||
-- )
|
||||
|
||||
-- updateIfDifferent ::
|
||||
-- forall label parsed.
|
||||
-- ( HasField "id_" parsed Json.Value,
|
||||
-- HasField "rulename" parsed Text
|
||||
-- ) =>
|
||||
-- Session ->
|
||||
-- (Dat label Json.Object parsed -> IO Json.Object) ->
|
||||
-- Json.Parse Error () ->
|
||||
-- Dat label Json.Object parsed ->
|
||||
-- IO ()
|
||||
-- updateIfDifferent session switcheroo parser dat = do
|
||||
-- new <- switcheroo dat
|
||||
-- if new /= getField @label dat.original
|
||||
-- then do
|
||||
-- log [fmt|Updating filter "{dat.parsed.rulename}" (id {dat.parsed.id_ & show @Json.Value})|]
|
||||
-- mailfilter
|
||||
-- session
|
||||
-- "update"
|
||||
-- mempty
|
||||
-- parser
|
||||
-- new
|
||||
-- else do
|
||||
-- log [fmt|Skipping updating filter "{dat.parsed.rulename}" (id {dat.parsed.id_ & show @Json.Value}) because nothing changed.|]
|
||||
|
||||
-- | https://oxpedia.org/wiki/index.php?title=HTTP_API_MailFilter
|
||||
mailfilter ::
|
||||
( Json.ToJSON a,
|
||||
Show b
|
||||
) =>
|
||||
Session ->
|
||||
ByteString ->
|
||||
T2
|
||||
"extraQueryParams"
|
||||
Client.Query
|
||||
"httpMethod"
|
||||
(Maybe ByteString) ->
|
||||
Json.Parse Error b ->
|
||||
a ->
|
||||
IO b
|
||||
mailfilter session action opts parser body = do
|
||||
req <-
|
||||
Client.parseRequest "https://office.mailbox.org/appsuite/api/mailfilter/v2"
|
||||
<&> Client.setQueryString
|
||||
( [ ("action", Just action),
|
||||
("colums", Just "1")
|
||||
]
|
||||
<> opts.extraQueryParams
|
||||
)
|
||||
<&> Client.setRequestMethod (opts.httpMethod & fromMaybe "PUT")
|
||||
<&> Client.setRequestBodyJSON body
|
||||
<&> addSession session
|
||||
req
|
||||
& httpJSON [fmt|Cannot parse result for {req & prettyRequestShort}|] parser
|
||||
>>= okOrDie
|
||||
-- >>= (\resp -> printPretty resp >> pure resp)
|
||||
<&> Client.responseBody
|
||||
where
|
||||
prettyRequestShort :: Client.Request -> Text
|
||||
prettyRequestShort req = [fmt|request {req & Client.method}: {req & Client.host}{req & Client.path}{req & Client.queryString}|]
|
||||
|
||||
-- | Given a goal and the actual state, return which elements to delete, update and create.
|
||||
declarativeUpdate ::
|
||||
Ord k =>
|
||||
-- | goal map
|
||||
Map k a ->
|
||||
-- | actual map
|
||||
Map k b ->
|
||||
T3
|
||||
"toCreate"
|
||||
(Map k a)
|
||||
"toDelete"
|
||||
(Map k b)
|
||||
"toUpdate"
|
||||
(Map k a)
|
||||
declarativeUpdate goal actual =
|
||||
T3
|
||||
(label @"toCreate" $ goal `Map.difference` actual)
|
||||
(label @"toDelete" $ actual `Map.difference` goal)
|
||||
(label @"toUpdate" $ goal `Map.intersection` actual)
|
||||
|
||||
newtype Session = Session Client.CookieJar
|
||||
|
||||
httpJSON ::
|
||||
Error ->
|
||||
Json.Parse Error b ->
|
||||
Client.Request ->
|
||||
IO (Client.Response b)
|
||||
httpJSON errMsg parser req = do
|
||||
req
|
||||
& Client.httpJSON @_ @Json.Value
|
||||
>>= traverse
|
||||
( \val -> do
|
||||
case val of
|
||||
Json.Object obj
|
||||
| "error" `KeyMap.member` obj
|
||||
&& "error_desc" `KeyMap.member` obj -> do
|
||||
printPretty obj
|
||||
diePanic' "Server returned above inline error"
|
||||
_ -> pure ()
|
||||
val & Json.parseValue parser & \case
|
||||
Left errs ->
|
||||
errs
|
||||
& parseErrorTree errMsg
|
||||
& diePanic'
|
||||
Right a -> pure a
|
||||
)
|
||||
|
||||
data Dat label orig parsed = Dat
|
||||
{ original :: Label label orig,
|
||||
parsed :: parsed
|
||||
}
|
||||
deriving stock (Show, Eq)
|
||||
|
||||
asDat ::
|
||||
forall label err m a.
|
||||
Monad m =>
|
||||
Json.ParseT err m a ->
|
||||
Json.ParseT err m (Dat label Json.Object a)
|
||||
asDat parser = do
|
||||
original <- label @label <$> Json.asObject
|
||||
parsed <- parser
|
||||
pure Dat {..}
|
||||
|
||||
addSession :: Session -> Client.Request -> Client.Request
|
||||
addSession (Session jar) req = do
|
||||
let sessionId =
|
||||
jar
|
||||
& Client.destroyCookieJar
|
||||
& List.find (\c -> "open-xchange-session-" `ByteString.isPrefixOf` c.cookie_name)
|
||||
& annotate "The cookie jar did not contain an open-exchange-session-*"
|
||||
& unwrapError
|
||||
& (.cookie_value)
|
||||
|
||||
let req' = req & Client.addToRequestQueryString [("session", Just sessionId)]
|
||||
req' {Client.cookieJar = Just jar}
|
||||
|
||||
-- | Log into the mailbox.org service, and return the session secret cookies.
|
||||
login :: (HasField "email" dat ByteString, HasField "password" dat ByteString) => dat -> IO Session
|
||||
login dat = do
|
||||
rnd <- randomString
|
||||
req <-
|
||||
Client.parseRequest "https://office.mailbox.org/ajax/login"
|
||||
<&> Client.setQueryString
|
||||
[ ("action", Just "formlogin"),
|
||||
("authId", Just $ ("mbo-" <> rnd) & stringToText & textToBytesUtf8)
|
||||
]
|
||||
<&> Client.urlEncodedBody
|
||||
[ ("version", "Form+Login"),
|
||||
("autologin", "true"),
|
||||
("client", "open-xchange-appsuite"),
|
||||
("uiWebPath", "/appsuite/"),
|
||||
("login", dat.email),
|
||||
("password", dat.password)
|
||||
]
|
||||
Client.httpNoBody req
|
||||
>>= okOrDie
|
||||
<&> Client.responseCookieJar
|
||||
<&> Session
|
||||
where
|
||||
-- For some reason they want the client to pass a random string
|
||||
-- which is used for the session?‽!?
|
||||
randomString = do
|
||||
gen <- Random.newIOGenM =<< Random.newStdGen
|
||||
let chars = ['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9']
|
||||
let len = 11
|
||||
Random.uniformRM (0, List.length chars - 1) gen
|
||||
& replicateM len
|
||||
<&> map (\index -> chars !! index)
|
||||
|
||||
okOrDie :: Show a => Client.Response a -> IO (Client.Response a)
|
||||
okOrDie resp =
|
||||
case resp & Client.getResponseStatusCode of
|
||||
200 -> pure resp
|
||||
_ -> do
|
||||
printPretty resp
|
||||
diePanic' "non-200 result"
|
||||
|
||||
diePanic' :: ErrorTree -> IO a
|
||||
diePanic' errs = errs & prettyErrorTree & diePanic progName
|
||||
|
||||
-- | Parse the tools from the given arglib input, and check that the executables exist
|
||||
parseToolsArglib :: Netencode.T -> IO Tools
|
||||
parseToolsArglib t = do
|
||||
let oneTool name =
|
||||
NetParse.asText
|
||||
<&> textToString
|
||||
<&> ( \path ->
|
||||
path
|
||||
& File.getPermissions
|
||||
<&> File.executable
|
||||
<&> ( \case
|
||||
False -> Left $ [fmt|Tool "{name}" is not an executable|]
|
||||
True -> Right (Tool path)
|
||||
)
|
||||
)
|
||||
let allTools =
|
||||
parseTools (\name -> Compose $ NetParse.key name >>> oneTool name)
|
||||
& getCompose
|
||||
t
|
||||
& NetParse.runParse
|
||||
"test"
|
||||
-- TODO: a proper ParseT for netencode values
|
||||
( NetParse.asRecord
|
||||
>>> NetParse.key "BINS"
|
||||
>>> NetParse.asRecord
|
||||
>>> allTools
|
||||
)
|
||||
& orDo diePanic'
|
||||
& join @IO
|
||||
>>= orDo (\errs -> errs & diePanic')
|
||||
|
||||
-- | Just assume the tools exist by name in the environment.
|
||||
parseToolsToolname :: IO Tools
|
||||
parseToolsToolname =
|
||||
parseTools
|
||||
( \name ->
|
||||
checkInPath name <&> \case
|
||||
False -> Left [fmt|"Cannot find "{name}" in PATH|]
|
||||
True -> Right $ Tool (name & textToString)
|
||||
)
|
||||
>>= orDo diePanic'
|
||||
|
||||
checkInPath :: Text -> IO Bool
|
||||
checkInPath name = do
|
||||
Env.lookupEnv "PATH"
|
||||
<&> annotate "No PATH set"
|
||||
>>= orDo diePanic'
|
||||
<&> stringToText
|
||||
<&> Text.split (== ':')
|
||||
<&> filter (/= "")
|
||||
>>= traverse
|
||||
( \p ->
|
||||
File.getPermissions ((textToString p) </> (textToString name))
|
||||
<&> File.executable
|
||||
& try @IOError
|
||||
>>= \case
|
||||
Left _ioError -> pure False
|
||||
Right isExe -> pure isExe
|
||||
)
|
||||
<&> or
|
||||
|
||||
orDo :: Applicative f => (t -> f a) -> Either t a -> f a
|
||||
orDo f = \case
|
||||
Left e -> f e
|
||||
Right a -> pure a
|
||||
|
||||
runTool :: [Text] -> Tool -> IO (Exit.ExitCode, ByteString)
|
||||
runTool args tool = do
|
||||
let bashArgs = prettyArgsForBash ((tool.unTool & stringToText) : args)
|
||||
log [fmt|Running: $ {bashArgs}|]
|
||||
Process.proc
|
||||
tool.unTool
|
||||
(args <&> textToString)
|
||||
& Process.readProcessStdout
|
||||
<&> second toStrictBytes
|
||||
<&> second stripWhitespaceFromEnd
|
||||
|
||||
-- | Like `runCommandExpect0`, run the given tool, given a tool accessor.
|
||||
runToolExpect0 :: [Text] -> Tool -> IO ByteString
|
||||
runToolExpect0 args tool =
|
||||
tool & runTool args >>= \(ex, stdout) -> do
|
||||
checkStatus0 tool.unTool ex
|
||||
pure stdout
|
||||
|
||||
-- | Check whether a command exited 0 or crash.
|
||||
checkStatus0 :: FilePath -> ExitCode -> IO ()
|
||||
checkStatus0 executable = \case
|
||||
ExitSuccess -> pure ()
|
||||
ExitFailure status -> do
|
||||
diePanic' [fmt|Command `{executable}` did not exit with status 0 (success), but status {status}|]
|
||||
|
||||
stripWhitespaceFromEnd :: ByteString -> ByteString
|
||||
stripWhitespaceFromEnd = ByteString.reverse . ByteString.dropWhile (\w -> w == charToWordUnsafe '\n') . ByteString.reverse
|
||||
|
||||
-- | Pretty print a command line in a way that can be copied to bash.
|
||||
prettyArgsForBash :: [Text] -> Text
|
||||
prettyArgsForBash = Text.intercalate " " . map simpleBashEscape
|
||||
|
||||
-- | Simple escaping for bash words. If they contain anything that’s not ascii chars
|
||||
-- and a bunch of often-used special characters, put the word in single quotes.
|
||||
simpleBashEscape :: Text -> Text
|
||||
simpleBashEscape t = do
|
||||
case Text.find (not . isSimple) t of
|
||||
Just _ -> escapeSingleQuote t
|
||||
Nothing -> t
|
||||
where
|
||||
-- any word that is just ascii characters is simple (no spaces or control characters)
|
||||
-- or contains a few often-used characters like - or .
|
||||
isSimple c =
|
||||
Char.isAsciiLower c
|
||||
|| Char.isAsciiUpper c
|
||||
|| Char.isDigit c
|
||||
-- These are benign, bash will not interpret them as special characters.
|
||||
|| List.elem c ['-', '.', ':', '/']
|
||||
-- Put the word in single quotes
|
||||
-- If there is a single quote in the word,
|
||||
-- close the single quoted word, add a single quote, open the word again
|
||||
escapeSingleQuote t' = "'" <> Text.replace "'" "'\\''" t' <> "'"
|
||||
7
users/Profpatsch/parked/mailbox-org/README.md
Normal file
7
users/Profpatsch/parked/mailbox-org/README.md
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
# mailbox-org
|
||||
|
||||
Interfacing with the API of [https://mailbox.org/]().
|
||||
|
||||
They use [open-xchange](https://www.open-xchange.com/resources/oxpedia) as their App Suite, so we have to work with/reverse engineer their weird API.
|
||||
|
||||
Intended so I have a way of uploading Sieve rules into their system semi-automatically.
|
||||
38
users/Profpatsch/parked/mailbox-org/default.nix
Normal file
38
users/Profpatsch/parked/mailbox-org/default.nix
Normal file
|
|
@ -0,0 +1,38 @@
|
|||
{ depot, pkgs, lib, ... }:
|
||||
|
||||
let
|
||||
mailbox-org = pkgs.haskellPackages.mkDerivation {
|
||||
pname = "mailbox-org";
|
||||
version = "0.1.0";
|
||||
|
||||
src = depot.users.Profpatsch.exactSource ./. [
|
||||
./mailbox-org.cabal
|
||||
./src/AesonQQ.hs
|
||||
./MailboxOrg.hs
|
||||
];
|
||||
|
||||
libraryHaskellDepends = [
|
||||
depot.users.Profpatsch.my-prelude
|
||||
depot.users.Profpatsch.execline.exec-helpers-hs
|
||||
depot.users.Profpatsch.arglib.netencode.haskell
|
||||
pkgs.haskellPackages.pa-prelude
|
||||
pkgs.haskellPackages.pa-label
|
||||
pkgs.haskellPackages.pa-error-tree
|
||||
pkgs.haskellPackages.aeson
|
||||
pkgs.haskellPackages.http-conduit
|
||||
pkgs.haskellPackages.aeson-better-errors
|
||||
];
|
||||
|
||||
isLibrary = false;
|
||||
isExecutable = true;
|
||||
license = lib.licenses.mit;
|
||||
};
|
||||
|
||||
|
||||
in
|
||||
lib.pipe mailbox-org [
|
||||
(x: (depot.nix.getBins x [ "mailbox-org" ]).mailbox-org)
|
||||
(depot.users.Profpatsch.arglib.netencode.with-args "mailbox-org" {
|
||||
BINS = depot.nix.getBins pkgs.dovecot_pigeonhole [ "sieve-test" ];
|
||||
})
|
||||
]
|
||||
95
users/Profpatsch/parked/mailbox-org/mailbox-org.cabal
Normal file
95
users/Profpatsch/parked/mailbox-org/mailbox-org.cabal
Normal file
|
|
@ -0,0 +1,95 @@
|
|||
cabal-version: 3.0
|
||||
name: mailbox-org
|
||||
version: 0.1.0.0
|
||||
author: Profpatsch
|
||||
maintainer: mail@profpatsch.de
|
||||
|
||||
|
||||
common common-options
|
||||
ghc-options:
|
||||
-Wall
|
||||
-Wno-type-defaults
|
||||
-Wunused-packages
|
||||
-Wredundant-constraints
|
||||
-fwarn-missing-deriving-strategies
|
||||
|
||||
-- See https://downloads.haskell.org/ghc/latest/docs/users_guide/exts.html
|
||||
-- for a description of all these extensions
|
||||
default-extensions:
|
||||
-- Infer Applicative instead of Monad where possible
|
||||
ApplicativeDo
|
||||
|
||||
-- Allow literal strings to be Text
|
||||
OverloadedStrings
|
||||
|
||||
-- Syntactic sugar improvements
|
||||
LambdaCase
|
||||
MultiWayIf
|
||||
|
||||
-- Makes the (deprecated) usage of * instead of Data.Kind.Type an error
|
||||
NoStarIsType
|
||||
|
||||
-- Convenient and crucial to deal with ambiguous field names, commonly
|
||||
-- known as RecordDotSyntax
|
||||
OverloadedRecordDot
|
||||
|
||||
-- does not export record fields as functions, use OverloadedRecordDot to access instead
|
||||
NoFieldSelectors
|
||||
|
||||
-- Record punning
|
||||
RecordWildCards
|
||||
|
||||
-- Improved Deriving
|
||||
DerivingStrategies
|
||||
DerivingVia
|
||||
|
||||
-- Type-level strings
|
||||
DataKinds
|
||||
|
||||
-- to enable the `type` keyword in import lists (ormolu uses this automatically)
|
||||
ExplicitNamespaces
|
||||
|
||||
default-language: GHC2021
|
||||
|
||||
|
||||
library
|
||||
import: common-options
|
||||
|
||||
hs-source-dirs: src
|
||||
|
||||
exposed-modules:
|
||||
AesonQQ
|
||||
|
||||
build-depends:
|
||||
base >=4.15 && <5,
|
||||
pa-prelude,
|
||||
aeson,
|
||||
PyF,
|
||||
template-haskell
|
||||
|
||||
|
||||
|
||||
executable mailbox-org
|
||||
import: common-options
|
||||
main-is: MailboxOrg.hs
|
||||
|
||||
build-depends:
|
||||
base >=4.15 && <5,
|
||||
mailbox-org,
|
||||
my-prelude,
|
||||
pa-prelude,
|
||||
pa-label,
|
||||
pa-error-tree,
|
||||
exec-helpers,
|
||||
netencode,
|
||||
text,
|
||||
directory,
|
||||
filepath,
|
||||
arglib-netencode,
|
||||
random,
|
||||
http-conduit,
|
||||
aeson,
|
||||
aeson-better-errors,
|
||||
bytestring,
|
||||
typed-process,
|
||||
containers,
|
||||
24
users/Profpatsch/parked/mailbox-org/src/AesonQQ.hs
Normal file
24
users/Profpatsch/parked/mailbox-org/src/AesonQQ.hs
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
{-# LANGUAGE TemplateHaskellQuotes #-}
|
||||
|
||||
module AesonQQ where
|
||||
|
||||
import Data.Aeson qualified as Json
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter)
|
||||
import PossehlAnalyticsPrelude
|
||||
import PyF qualified
|
||||
import PyF.Internal.QQ qualified as PyFConf
|
||||
|
||||
aesonQQ :: QuasiQuoter
|
||||
aesonQQ =
|
||||
PyF.mkFormatter
|
||||
"aesonQQ"
|
||||
PyF.defaultConfig
|
||||
{ PyFConf.delimiters = Just ('|', '|'),
|
||||
PyFConf.postProcess = \exp_ -> do
|
||||
-- TODO: this does not throw an error at compilation time if the json does not parse
|
||||
[|
|
||||
case Json.eitherDecodeStrict' @Json.Value $ textToBytesUtf8 $ stringToText $(exp_) of
|
||||
Left err -> error err
|
||||
Right a -> a
|
||||
|]
|
||||
}
|
||||
Loading…
Add table
Add a link
Reference in a new issue