feat(users/Profpatsch/mailbox-org): init

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 <mail@profpatsch.de>
Autosubmit: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI

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"

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

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

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

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]

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;

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