From 067c9c10e08bc48678687996945b35fa921229f4 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 26 Jan 2017 22:10:29 +0100 Subject: Basic concepts --- all.gup | 3 +++ lib/Postdelay/Scan.hs | 43 +++++++++++++++++++++++++++++++++++++++++++ lib/Postdelay/TimeSpec.hs | 14 ++++++++++++++ lib/Postdelay/Types.hs | 13 +++++++++++++ lib/Postdelay/Utils.hs | 21 +++++++++++++++++++++ postdelay.cabal | 20 ++++++++++++++++++-- postdelay.nix | 11 ++++++++--- postdelay.nix.gup | 0 result.gup | 4 ++++ src/Main.hs | 4 ---- src/Simple.hs | 24 ++++++++++++++++++++++++ 11 files changed, 148 insertions(+), 9 deletions(-) create mode 100644 all.gup create mode 100644 lib/Postdelay/Scan.hs create mode 100644 lib/Postdelay/TimeSpec.hs create mode 100644 lib/Postdelay/Types.hs create mode 100644 lib/Postdelay/Utils.hs mode change 100755 => 100644 postdelay.nix.gup create mode 100644 result.gup delete mode 100644 src/Main.hs create mode 100644 src/Simple.hs diff --git a/all.gup b/all.gup new file mode 100644 index 0000000..c83d29c --- /dev/null +++ b/all.gup @@ -0,0 +1,3 @@ +#!/usr/bin/env zsh + +gup -u result \ No newline at end of file diff --git a/lib/Postdelay/Scan.hs b/lib/Postdelay/Scan.hs new file mode 100644 index 0000000..e6de0cf --- /dev/null +++ b/lib/Postdelay/Scan.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, FlexibleContexts #-} + +module Postdelay.Scan + ( scan + , Delay(..) + , ParseError(..) + ) where + +import Postdelay.Types +import Postdelay.Utils +import Postdelay.TimeSpec + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Error.Class + +import Text.Parsec.Char +import Text.Parsec.Prim +import Text.Parsec.Combinator +import Text.Parsec.Error (ParseError(..)) +import Text.ParserCombinators.Parsec.Rfc2822 + +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + +import Data.Either +import Data.Foldable +import Data.Semigroup + + +scan :: (MonadIO m, MonadError ParseError m) => String -> m (Maybe Delay) +scan = fmap getOption . extractDelay <=< either throwError return . parse message "" + +extractDelay :: forall m. (MonadIO m, MonadError ParseError m) => Message -> m (Option Delay) +extractDelay (Message headers _) = foldMap pure <$> mapM parseDelay delayHeaders + where + delayHeaders :: [Field] + delayHeaders = do + h@(OptionalField field content) <- headers + guard $ CI.mk field == "X-Delay" + return h + parseDelay :: Field -> m Delay + parseDelay (OptionalField field content) = either throwError return =<< runParserT (Until <$> pTimeSpec) () field content diff --git a/lib/Postdelay/TimeSpec.hs b/lib/Postdelay/TimeSpec.hs new file mode 100644 index 0000000..b080dcc --- /dev/null +++ b/lib/Postdelay/TimeSpec.hs @@ -0,0 +1,14 @@ +module Postdelay.TimeSpec + ( pTimeSpec + ) where + +import Control.Monad.IO.Class +import Data.Time + +import Text.Parsec.Char +import Text.Parsec.Prim +import Text.Parsec.Combinator +import Text.Parsec.Error (ParseError(..)) + +pTimeSpec :: MonadIO m => ParsecT String () m UTCTime +pTimeSpec = undefined diff --git a/lib/Postdelay/Types.hs b/lib/Postdelay/Types.hs new file mode 100644 index 0000000..3f66fb8 --- /dev/null +++ b/lib/Postdelay/Types.hs @@ -0,0 +1,13 @@ +module Postdelay.Types + ( Delay(..) + ) where + +import Data.Semigroup + +import Data.Time.Clock (UTCTime) + +newtype Delay = Until { releaseTime :: UTCTime } + deriving (Eq, Ord) + +instance Semigroup Delay where + (Until a) <> (Until b) = Until $ max a b diff --git a/lib/Postdelay/Utils.hs b/lib/Postdelay/Utils.hs new file mode 100644 index 0000000..d716b4d --- /dev/null +++ b/lib/Postdelay/Utils.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Postdelay.Utils + ( hoistParsecT + ) where + +import Control.Monad.Error.Class + +import Data.Functor +import Data.Either + +import Data.Functor.Identity +import Text.Parsec.Prim +import Text.Parsec.Error + +hoistParsecT :: (Monad m, Stream s Identity t, Stream s m t) => ParsecT s u Identity a -> ParsecT s u m a +hoistParsecT p = do + st <- getParserState + let res = runParser p' undefined "" undefined + p' = setParserState st >> ((,) <$> getState <*> p) + either (fail . show) (\(st', res) -> putState st' $> res) $ res diff --git a/postdelay.cabal b/postdelay.cabal index 9f13336..957e6d5 100644 --- a/postdelay.cabal +++ b/postdelay.cabal @@ -16,10 +16,26 @@ build-type: Simple -- extra-source-files: cabal-version: >=1.10 -executable postdelay - main-is: Main.hs +library + exposed-modules: Postdelay.Scan + , Postdelay.Types + other-modules: Postdelay.Utils + , Postdelay.TimeSpec + build-depends: base >=4.9 && <5 + , time >=1.6 && <2 + , parsec >=3.1 && <4 + , case-insensitive >=1.2 && <2 + , hsemail >=1.7 && <2 + , mtl >=2.2 && <3 + hs-source-dirs: lib + default-language: Haskell2010 + +executable postdelay-simple + main-is: Simple.hs -- other-modules: -- other-extensions: build-depends: base >=4.9 && <5 + , postdelay + , transformers >=0.5 && <1 hs-source-dirs: src default-language: Haskell2010 diff --git a/postdelay.nix b/postdelay.nix index 1ef3413..66dae61 100644 --- a/postdelay.nix +++ b/postdelay.nix @@ -1,11 +1,16 @@ -{ mkDerivation, base, stdenv }: +{ mkDerivation, base, case-insensitive, hsemail, mtl, parsec +, stdenv, time, transformers +}: mkDerivation { pname = "postdelay"; version = "0.0.0"; src = ./.; - isLibrary = false; + isLibrary = true; isExecutable = true; - executableHaskellDepends = [ base ]; + libraryHaskellDepends = [ + base case-insensitive hsemail mtl parsec time + ]; + executableHaskellDepends = [ base transformers ]; homepage = "https://git.yggdrasil.li/gkleen/pub/postdelay"; description = "A postfix content filter for delaying delivery of mail"; license = stdenv.lib.licenses.mit; diff --git a/postdelay.nix.gup b/postdelay.nix.gup old mode 100755 new mode 100644 diff --git a/result.gup b/result.gup new file mode 100644 index 0000000..5c03e49 --- /dev/null +++ b/result.gup @@ -0,0 +1,4 @@ +#!/usr/bin/env zsh + +gup -u postdelay.nix default.nix +nix-build -o ${1} ./default.nix \ No newline at end of file diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 index 65ae4a0..0000000 --- a/src/Main.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - -main :: IO () -main = putStrLn "Hello, Haskell!" diff --git a/src/Simple.hs b/src/Simple.hs new file mode 100644 index 0000000..f461766 --- /dev/null +++ b/src/Simple.hs @@ -0,0 +1,24 @@ +module Main (main) where + +import Postdelay.Scan + +import Control.Monad.IO.Class +import Control.Monad.Trans.Except + + +main :: MonadIO m => m () +main = do + mailStr <- liftIO getContents + delay <- runExceptT $ scan mailStr + case delay of + Left err -> do + liftIO . putStrLn $ show err + sendNow mailStr + Right Nothing -> sendNow mailStr + Right (Just d) -> sendLater mailStr d + +sendNow :: MonadIO m => String -> m () +sendNow = undefined + +sendLater :: MonadIO m => String -> Delay -> m () +sendLater = undefined -- cgit v1.2.3