diff options
| -rw-r--r-- | users/Profpatsch/mailbox-org/MailboxOrg.hs | 112 | ||||
| -rw-r--r-- | users/Profpatsch/mailbox-org/default.nix | 16 | ||||
| -rw-r--r-- | users/Profpatsch/mailbox-org/mailbox-org.cabal | 20 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/MyPrelude.hs | 136 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/Pretty.hs | 87 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/default.nix | 4 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/my-prelude.cabal | 4 |
7 files changed, 334 insertions, 45 deletions
diff --git a/users/Profpatsch/mailbox-org/MailboxOrg.hs b/users/Profpatsch/mailbox-org/MailboxOrg.hs new file mode 100644 index 000000000000..a7eab3305f6a --- /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 000000000000..b9b0c0f5f41d --- /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 000000000000..eab66242d4db --- /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 a2c99bc9ead2..4ef59c05ffba 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 000000000000..8a58a5934e17 --- /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 797beda82eff..87731394fc47 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 508bbba055dc..48e71bb926a3 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 |