From 7168cb0ed39346049280db8edde34cd79ea0de59 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Sun, 1 Jan 2023 22:44:02 +0100 Subject: [PATCH] feat(users/Profpatsch/mailbox-org): init MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A smol little tool to talk to the mailbox.org backend. This is handy for eventually setting stuff like email filters. Their API is absolute crap, but we’ll deal with it. Updates the prelude & adds some pretty printing helpers. Change-Id: Ie3688f8ee1d7f23c65bcf4bfecc00c8269dae788 Reviewed-on: https://cl.tvl.fyi/c/depot/+/7717 Reviewed-by: Profpatsch Autosubmit: Profpatsch Tested-by: BuildkiteCI --- users/Profpatsch/mailbox-org/MailboxOrg.hs | 112 +++++++++++++++ users/Profpatsch/mailbox-org/default.nix | 16 +++ .../Profpatsch/mailbox-org/mailbox-org.cabal | 20 +++ users/Profpatsch/my-prelude/MyPrelude.hs | 136 ++++++++++++------ users/Profpatsch/my-prelude/Pretty.hs | 87 +++++++++++ users/Profpatsch/my-prelude/default.nix | 4 + users/Profpatsch/my-prelude/my-prelude.cabal | 4 + 7 files changed, 334 insertions(+), 45 deletions(-) create mode 100644 users/Profpatsch/mailbox-org/MailboxOrg.hs create mode 100644 users/Profpatsch/mailbox-org/default.nix create mode 100644 users/Profpatsch/mailbox-org/mailbox-org.cabal create mode 100644 users/Profpatsch/my-prelude/Pretty.hs diff --git a/users/Profpatsch/mailbox-org/MailboxOrg.hs b/users/Profpatsch/mailbox-org/MailboxOrg.hs new file mode 100644 index 000000000..a7eab3305 --- /dev/null +++ b/users/Profpatsch/mailbox-org/MailboxOrg.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} + +module Main where + +import Control.Monad (replicateM) +import Data.ByteString qualified as ByteString +import Data.List qualified as List +import MyPrelude +import Network.HTTP.Conduit qualified as Client +import Network.HTTP.Simple qualified as Client +import Pretty +import System.Exit qualified as Exit +import System.Random qualified as Random +import System.Random.Stateful qualified as Random +import Prelude hiding (log) +import Data.Aeson (Value) +import Label +import qualified System.Process as Proc +import qualified Data.ByteString.Char8 as Char8 + +secret :: IO (T2 "email" ByteString "password" ByteString) +secret = do + T2 + (label @"email" "mail@profpatsch.de") + <$> (label @"password" <$> fromPass "email/mailbox.org" ) + where + fromPass name = Proc.readProcess "pass" [name] "" + <&> stringToText <&> textToBytesUtf8 + <&> Char8.strip + +main :: IO () +main = run =<< secret + + +run :: (HasField "email" dat ByteString, + HasField "password" dat ByteString) => + dat -> IO () +run dat = do + session <- login dat + req <- Client.parseRequest "https://office.mailbox.org/appsuite/api/mailfilter/v2?action=list&columns=1" + <&> Client.setRequestMethod "PUT" + <&> addSession session + Client.httpJSON @_ @Value req + >>= okOrDie + <&> Client.responseBody + >>= printPretty + +newtype Session = Session Client.CookieJar + +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) + (req + & Client.addToRequestQueryString [("session", Just sessionId)]) + { 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 + Exit.die "non-200 result" diff --git a/users/Profpatsch/mailbox-org/default.nix b/users/Profpatsch/mailbox-org/default.nix new file mode 100644 index 000000000..b9b0c0f5f --- /dev/null +++ b/users/Profpatsch/mailbox-org/default.nix @@ -0,0 +1,16 @@ +{ depot, pkgs, lib, ... }: + +let + cas-serve = pkgs.writers.writeHaskell "mailbox-org" + { + libraries = [ + depot.users.Profpatsch.my-prelude + pkgs.haskellPackages.aeson + pkgs.haskellPackages.http-conduit + + ]; + ghcArgs = [ "-threaded" ]; + } ./MailboxOrg.hs; + +in +cas-serve diff --git a/users/Profpatsch/mailbox-org/mailbox-org.cabal b/users/Profpatsch/mailbox-org/mailbox-org.cabal new file mode 100644 index 000000000..eab66242d --- /dev/null +++ b/users/Profpatsch/mailbox-org/mailbox-org.cabal @@ -0,0 +1,20 @@ +cabal-version: 2.4 +name: mailbox-org +version: 0.1.0.0 +author: Profpatsch +maintainer: mail@profpatsch.de + +executable mailbox-org + main-is: MailboxOrg.hs + + build-depends: + base >=4.15 && <5, + my-prelude, + random, + http-conduit, + http-client, + aeson, + bytestring, + process + + default-language: Haskell2010 diff --git a/users/Profpatsch/my-prelude/MyPrelude.hs b/users/Profpatsch/my-prelude/MyPrelude.hs index a2c99bc9e..4ef59c05f 100644 --- a/users/Profpatsch/my-prelude/MyPrelude.hs +++ b/users/Profpatsch/my-prelude/MyPrelude.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GHC2021 #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} @@ -5,6 +6,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fexpose-all-unfoldings #-} module MyPrelude ( -- * Text conversions @@ -37,6 +39,9 @@ module MyPrelude -- * WIP code todo, + -- * Records + HasField, + -- * Control flow (&), (<&>), @@ -59,9 +64,11 @@ module MyPrelude first, second, bimap, + both, foldMap, fold, foldl', + fromMaybe, mapMaybe, findMaybe, Traversable, @@ -105,6 +112,8 @@ module MyPrelude sconcat, Monoid, mconcat, + ifTrue, + ifExists, Void, absurd, Identity (Identity, runIdentity), @@ -120,8 +129,8 @@ module MyPrelude rmap, Semigroupoid, Category, - (<<<), (>>>), + (&>>), -- * Enum definition inverseFunction, @@ -130,12 +139,11 @@ module MyPrelude -- * Error handling HasCallStack, module Data.Error, - smushErrors, ) where import Control.Applicative ((<|>)) -import Control.Category (Category, (<<<), (>>>)) +import Control.Category (Category, (>>>)) import Control.Monad (guard, join, unless, when) import Control.Monad.Except ( ExceptT, @@ -150,13 +158,13 @@ import Data.Bifunctor (Bifunctor, bimap, first, second) import Data.ByteString ( ByteString, ) -import qualified Data.ByteString.Lazy -import qualified Data.Char +import Data.ByteString.Lazy qualified +import Data.Char qualified import Data.Coerce (Coercible, coerce) import Data.Data (Proxy (Proxy)) import Data.Error import Data.Foldable (Foldable (foldMap', toList), fold, foldl', for_, traverse_) -import qualified Data.Foldable as Foldable +import Data.Foldable qualified as Foldable import Data.Function ((&)) import Data.Functor ((<&>)) import Data.Functor.Contravariant (Contravariant (contramap), (>$<)) @@ -165,22 +173,22 @@ import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) import Data.Map.Strict ( Map, ) -import qualified Data.Map.Strict as Map -import Data.Maybe (mapMaybe) -import qualified Data.Maybe as Maybe +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe qualified as Maybe import Data.Profunctor (Profunctor, dimap, lmap, rmap) import Data.Semigroup (Max (Max, getMax), Min (Min, getMin), sconcat) import Data.Semigroup.Foldable (Foldable1 (fold1), foldMap1) import Data.Semigroup.Traversable (Traversable1) -import Data.Semigroupoid (Semigroupoid) +import Data.Semigroupoid (Semigroupoid (o)) import Data.Text ( Text, ) -import qualified Data.Text -import qualified Data.Text.Encoding -import qualified Data.Text.Encoding.Error -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Encoding +import Data.Text qualified +import Data.Text.Encoding qualified +import Data.Text.Encoding.Error qualified +import Data.Text.Lazy qualified +import Data.Text.Lazy.Encoding qualified import Data.These (These (That, These, This)) import Data.Traversable (for) import Data.Void (Void, absurd) @@ -189,10 +197,11 @@ import GHC.Exception (errorCallWithCallStackException) import GHC.Exts (RuntimeRep, TYPE, raise#) import GHC.Generics (Generic) import GHC.Natural (Natural) +import GHC.Records (HasField) import GHC.Stack (HasCallStack) import PyF (fmt) -import qualified System.Exit -import qualified System.IO +import System.Exit qualified +import System.IO qualified import Validation ( Validation (Failure, Success), eitherToValidation, @@ -208,6 +217,20 @@ import Validation infixl 5 >&< +-- | Forward semigroupoid application. The same as '(>>>)', but 'Semigroupoid' is not a superclass of 'Category' (yet). +-- +-- Specialized examples: +-- +-- @@ +-- for functions : (a -> b) -> (b -> c) -> (a -> c) +-- for Folds: Fold a b -> Fold b c -> Fold a c +-- @@ +(&>>) :: Semigroupoid s => s a b -> s b c -> s a c +(&>>) = flip Data.Semigroupoid.o + +-- like >>> +infixr 1 &>> + -- | encode a Text to a UTF-8 encoded Bytestring textToBytesUtf8 :: Text -> ByteString textToBytesUtf8 = Data.Text.Encoding.encodeUtf8 @@ -309,6 +332,10 @@ annotate err = \case Nothing -> Left err Just a -> Right a +-- | Map the same function over both sides of a Bifunctor (e.g. a tuple). +both :: Bifunctor bi => (a -> b) -> bi a a -> bi b b +both f = bimap f f + -- | Find the first element for which pred returns `Just a`, and return the `a`. -- -- Example: @@ -430,33 +457,6 @@ traverseFold1 f xs = fold1 <$> traverse f xs todo :: forall (r :: RuntimeRep). forall (a :: TYPE r). HasCallStack => a todo = raise# (errorCallWithCallStackException "This code was not yet implemented: TODO" ?callStack) --- TODO: use a Text.Builder? - --- | Pretty print a bunch of errors, on multiple lines, prefixed by the given message, --- then turn the result back into an 'Error'. --- --- Example: --- --- smushErrors "There was a problem with the frobl" --- [ (anyhow "frobz") --- , (errorContext "oh no" (anyhow "barz")) --- ] --- --- ==> --- "There was a problem with the frobl\n\ --- - frobz\n\ --- - oh no: barz\n" --- @ --- --- TODO how do we make this compatible with/integrate it into the Error library? -smushErrors :: Foldable t => Text -> t Error -> Error -smushErrors msg errs = - errs - -- hrm, pretty printing and then creating a new error is kinda shady - & foldMap (\err -> "\n- " <> prettyError err) - & newError - & errorContext msg - -- | Convert an integer to a 'Natural' if possible -- -- Named the same as the function from "GHC.Natural", but does not crash. @@ -536,5 +536,51 @@ inverseMap f = <&> (\a -> (f a, a)) & Map.fromList where - universe :: (Bounded a, Enum a) => [a] + universe :: [a] universe = [minBound .. maxBound] + +-- | If the predicate is true, return the @m@, else 'mempty'. +-- +-- This can be used (together with `ifExists`) to e.g. create lists with optional elements: +-- +-- >>> import Data.Monoid (Sum(..)) +-- +-- >>> :{ mconcat [ +-- ifTrue (1 == 1) [1], +-- [2, 3, 4], +-- ifTrue False [5], +-- ] +-- :} +-- [1,2,3,4] +-- +-- Or any other Monoid: +-- +-- >>> mconcat [ Sum 1, ifTrue (1 == 1) (Sum 2), Sum 3 ] + +-- Sum {getSum = 6} + +ifTrue :: Monoid m => Bool -> m -> m +ifTrue pred' m = if pred' then m else mempty + +-- | If the given @Maybe@ is @Just@, return the @m@, else return mempty. + +-- This can be used (together with `ifTrue`) to e.g. create lists with optional elements: +-- +-- >>> import Data.Monoid (Sum(..)) +-- +-- >>> :{ mconcat [ +-- ifExists (Just [1]), +-- [2, 3, 4], +-- ifExists Nothing, +-- ] +-- :} +-- [1,2,3,4] +-- +-- Or any other Monoid: +-- +-- >>> mconcat [ Sum 1, ifExists (Just (Sum 2)), Sum 3 ] + +-- Sum {getSum = 6} + +ifExists :: Monoid m => Maybe m -> m +ifExists = fold diff --git a/users/Profpatsch/my-prelude/Pretty.hs b/users/Profpatsch/my-prelude/Pretty.hs new file mode 100644 index 000000000..8a58a5934 --- /dev/null +++ b/users/Profpatsch/my-prelude/Pretty.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} + +module Pretty + ( -- * Pretty printing for error messages + Err, + printPretty, + -- constructors hidden + prettyErrs, + message, + messageString, + pretty, + prettyString, + hscolour', + ) +where + +import Data.List qualified as List +import Data.Text qualified as Text +import Language.Haskell.HsColour + ( Output (TTYg), + hscolour, + ) +import Language.Haskell.HsColour.ANSI (TerminalType (..)) +import Language.Haskell.HsColour.Colourise + ( defaultColourPrefs, + ) +import MyPrelude +import System.Console.ANSI (setSGRCode) +import System.Console.ANSI.Types + ( Color (Red), + ColorIntensity (Dull), + ConsoleLayer (Foreground), + SGR (Reset, SetColor), + ) +import Text.Nicify (nicify) + +-- | Print any 'Show'able type to stderr, formatted nicely and in color. Very helpful for debugging. +printPretty :: Show a => a -> IO () +printPretty a = + a & pretty & (: []) & prettyErrs & stringToText & putStderrLn + +-- | Display a list of 'Err's as a colored error message +-- and abort the test. +prettyErrs :: [Err] -> String +prettyErrs errs = res + where + res = List.intercalate "\n" $ map one errs + one = \case + ErrMsg s -> color Red s + ErrPrettyString s -> prettyShowString s + -- Pretty print a String that was produced by 'show' + prettyShowString :: String -> String + prettyShowString = hscolour' . nicify + +-- | Small DSL for pretty-printing errors +data Err + = -- | Message to display in the error + ErrMsg String + | -- | Pretty print a String that was produced by 'show' + ErrPrettyString String + +-- | Plain message to display, as 'Text' +message :: Text -> Err +message = ErrMsg . Text.unpack + +-- | Plain message to display, as 'String' +messageString :: String -> Err +messageString = ErrMsg + +-- | Any 'Show'able to pretty print +pretty :: Show a => a -> Err +pretty x = ErrPrettyString $ show x + +-- | Pretty print a String that was produced by 'show' +prettyString :: String -> Err +prettyString s = ErrPrettyString s + +-- Prettifying Helpers, mostly stolen from +-- https://hackage.haskell.org/package/hspec-expectations-pretty-diff-0.7.2.5/docs/src/Test.Hspec.Expectations.Pretty.html#prettyColor + +hscolour' :: String -> String +hscolour' = + hscolour (TTYg Ansi16Colour) defaultColourPrefs False False "" False + +color :: Color -> String -> String +color c s = setSGRCode [SetColor Foreground Dull c] ++ s ++ setSGRCode [Reset] diff --git a/users/Profpatsch/my-prelude/default.nix b/users/Profpatsch/my-prelude/default.nix index 797beda82..87731394f 100644 --- a/users/Profpatsch/my-prelude/default.nix +++ b/users/Profpatsch/my-prelude/default.nix @@ -8,6 +8,7 @@ pkgs.haskellPackages.mkDerivation { ./my-prelude.cabal ./MyPrelude.hs ./Label.hs + ./Pretty.hs ]; isLibrary = true; @@ -21,6 +22,9 @@ pkgs.haskellPackages.mkDerivation { pkgs.haskellPackages.validation-selective pkgs.haskellPackages.error + pkgs.haskellPackages.hscolour + pkgs.haskellPackages.nicify-lib + pkgs.haskellPackages.ansi-terminal ]; license = lib.licenses.mit; diff --git a/users/Profpatsch/my-prelude/my-prelude.cabal b/users/Profpatsch/my-prelude/my-prelude.cabal index 508bbba05..48e71bb92 100644 --- a/users/Profpatsch/my-prelude/my-prelude.cabal +++ b/users/Profpatsch/my-prelude/my-prelude.cabal @@ -8,6 +8,7 @@ library exposed-modules: MyPrelude Label + Pretty -- Modules included in this executable, other than Main. -- other-modules: @@ -26,4 +27,7 @@ library , error , bytestring , mtl + , hscolour + , nicify-lib + , ansi-terminal default-language: Haskell2010