diff --git a/CONTRIBUTE.md b/CONTRIBUTE.md new file mode 100644 --- /dev/null +++ b/CONTRIBUTE.md @@ -0,0 +1,24 @@ + +Patches/pull requests welcome, +follow the usual `git` workflow for submitting a pull request: + +- fork the project +- create a new branch from master (e.g. `features/my-new-feature` or + `issue/123-my-bugfix`) + +If you're fixing a bug also create an issue +on [GitHub](https://github.com/phlummox/assumpta/issues) +if one doesn't exist yet. + +If it's a new feature explain why you think it's useful or necessary. + +Follow the same coding style with regards to spaces, semicolons, variable +naming etc. In general, we follow the usual Haskell naming convention of making +function and variable names `camelCase` +(even +when they include +[acronyms](https://stackoverflow.com/questions/15526107/acronyms-in-camelcase)). +Mostly. + +Please add tests for any contributions you make. + diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,7 @@ +# Changelog for hs-smtp-client + +## Unreleased changes + +## 0.1.0.0 + +Unleashed on the world. diff --git a/DEVELOPMENT.md b/DEVELOPMENT.md new file mode 100644 --- /dev/null +++ b/DEVELOPMENT.md @@ -0,0 +1,39 @@ +# Development notes and tips + +I build and test assumpta and assumpta-core +using [`stack`](https://docs.haskellstack.org/en/stable/README/), +plus CI services (Travis CI and CircleCI). + +CircleCI in general is much more irritating, doesn't natively support +'test matrixes', and has obviously had less thought put into its design; +but it's faster, seems to do a better job of cacheing build artifacts, +and lets you use any Docker image you like to run tests in (unlike Travis CI, +which only has a fixed set of supported environments). + +If anyone wants to suggest things which might make the source tree +more friendly to cabal-users, feel free to let me know. + +## Tests + +### Compile-examples + +The test suite `compile-examples` (which checks that the +programs in the `examples` directory can be compiled) +requires stack to run, and will +fail if a `STACK_RESOLVER` environment variable isn't found (or if +it can't find `stack` on the `$PATH`). It also is normally disabled, +unless the `stack-based-tests` flag is enabled. + +So it is best run like this: + +```bash +$ export STACK_RESOLVER=lts-12.26 +$ stack --resolver="${STACK_RESOLVER}" test --flag assumpta:stack-based-tests +``` + +The aim of the test is just to ensure that the examples +are in sync with the API, so I haven't attempted to +get the test working in any other environment. + + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +Copyright 2019 Phlummox + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED +TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,13 @@ +# assumpta [![Hackage version](https://img.shields.io/hackage/v/assumpta.svg?label=Hackage)](https://hackage.haskell.org/package/assumpta) [![Linux Build Status](https://img.shields.io/travis/com/phlummox/assumpta.svg?label=Linux%20build)](https://travis-ci.com/phlummox/assumpta) [![phlummox](https://circleci.com/gh/phlummox/assumpta.svg?style=svg)](https://circleci.com/gh/phlummox/assumpta) + +An SMTP client library. It provides functionality for sending SMTP +commands (including `STARTTLS`) to a server and checking for expected +responses. Also for just sending an email. + +## Usage + +See the `simple-client-session-bs.hs` program in the `examples` +directory, or the `Network.Mail.Assumpta.ByteString` module +for examples of usage. + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/TODO.md b/TODO.md new file mode 100644 --- /dev/null +++ b/TODO.md @@ -0,0 +1,27 @@ + +# TODO + +## Add 'period-escaping' functions for ByteStrings + +The Text and String modules have utility functions for +escaping periods at the start of lines, the +ByteString one does not, as yet. +The 'stringsearch' package will do search-and-replace on +ByteStrings if we don't want to write our own impl. + +## easy ways of mocking and logging + +- Nice simple ergonomic way of substituting a mock + server for a real one, and for logging data passing + thru + +## more tests + +- Test that package builds cleanly from an sdist + source distribution tgz. +- Test that Haddock documentation builds cleanly + +## build sdist from CI + +- add Releases to GitHub + diff --git a/assumpta.cabal b/assumpta.cabal new file mode 100644 --- /dev/null +++ b/assumpta.cabal @@ -0,0 +1,139 @@ +cabal-version: 1.12 + +name: assumpta +version: 0.1.0.0 +synopsis: An SMTP client library +description: An SMTP client library, + which allows you to send email via + an SMTP server. + . + For further details, please see the README on GitHub at + . +category: Network +homepage: https://github.com/phlummox/assumpta#readme +bug-reports: https://github.com/phlummox/assumpta/issues +author: phlummox +maintainer: phlummox2@gmail.com +copyright: 2020 phlummox +license: BSD2 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + CONTRIBUTE.md + DEVELOPMENT.md + TODO.md + examples/simple-client-session-bs.hs + examples/simple-client-session-text.hs + scripts/stack-test.sh + stack-lts-12.26.yaml + +source-repository head + type: git + location: https://github.com/phlummox/assumpta + +-- This enables (or disables) tests that rely on +-- "stack": just the example compilation +-- test, at the moment. +-- You can enable these tests from stack using +-- `--flag assumpta-core:stack-based-tests` +flag stack-based-tests + description: enable tests requiring stack + manual: True + default: False + +flag warnmore + description: Enable plenty of ghc warning flags + manual: True + default: True + +library + exposed-modules: + Network.Mail.Assumpta.Internal.Net + Network.Mail.Assumpta.ByteString + Network.Mail.Assumpta.Text + Network.Mail.Assumpta.String + hs-source-dirs: + src + build-depends: + base >=4.0 && <5 + , assumpta-core == 0.1.* + , bytestring + , connection + , data-default + , exceptions + , mime-mail + , mtl + , text + , transformers + if flag(warnmore) + if impl(ghc >= 8.0.1) + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints + -Wno-name-shadowing -Wno-orphans -fwarn-tabs + else + ghc-options: + -Wall + default-language: Haskell2010 + + + +test-suite hspec-tests + type: exitcode-stdio-1.0 + main-is: hspec-tests.hs + other-modules: + Network.Mail.Assumpta.ByteStringSpec + hs-source-dirs: + test-hspec + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck + , assumpta + , base >=4.0 && <5 + , assumpta-core + , bytestring + , hspec + , network < 3 + , quickcheck-io + if flag(warnmore) + if impl(ghc >= 8.0.1) + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints + -Wno-name-shadowing -Wno-orphans -fwarn-tabs + else + ghc-options: + -Wall + default-language: Haskell2010 + +-- ** +-- - Only works with stack +-- - requires STACK_RESOLVER env var to be set +test-suite compile-examples + type: exitcode-stdio-1.0 + main-is: compile-examples.hs + hs-source-dirs: + test-other + ghc-options: -threaded -rtsopts -with-rtsopts=-N + if !(flag(stack-based-tests)) + buildable: False + else + build-depends: + assumpta + , assumpta-core + , base >=4.0 && <5 + , filepath + , shelly + , text + if flag(warnmore) + if impl(ghc >= 8.0.1) + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints + -Wno-name-shadowing -Wno-orphans -fwarn-tabs + else + ghc-options: + -Wall + default-language: Haskell2010 diff --git a/examples/simple-client-session-bs.hs b/examples/simple-client-session-bs.hs new file mode 100644 --- /dev/null +++ b/examples/simple-client-session-bs.hs @@ -0,0 +1,48 @@ + +{-# LANGUAGE OverloadedStrings #-} + +-- Program that runs a short SMTP session +-- with a server running on local port 2025. + +module Main where + +import Data.Monoid +import qualified Data.ByteString.Char8 as BS +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Network.BSD (getHostName) -- needs 'network' package for this +import Network.Mail.Assumpta.ByteString as M + +sampleMesg :: BS.ByteString +sampleMesg = BS.intercalate crlf [ + "Date: Tue, 21 Jan 2020 02:28:37 +0800" + , "To: neddie.seagoon@gmail.com" + , "From: jim.moriarty@gmail.com" + , "Subject: test Tue, 21 Jan 2020 02:28:37 +0800" + , "" + , "Sapristi nyuckoes!" + ] + +-- The sender and recipient supplied to the +-- SMTP server are what is used to route the +-- message; any 'To:' and 'From:' fields +-- in the message are completely ignored for this +-- purpose. +sender, recipient :: BS.ByteString +sender = "somesender@mycorp.com" +recipient = "somerecipient@mozilla.org" + +main :: IO () +main = do + let toBinary = TE.encodeUtf8 . T.pack + port = 2025 + hostname <- getHostName + print =<< runSmtp "localhost" port (do + expectGreeting + ehlo $ toBinary hostname + -- Properly, we should escape periods at the start of a + -- line. But we know there aren't any + sendRawMail sender [recipient] sampleMesg + quit) + + diff --git a/examples/simple-client-session-text.hs b/examples/simple-client-session-text.hs new file mode 100644 --- /dev/null +++ b/examples/simple-client-session-text.hs @@ -0,0 +1,46 @@ + +{-# LANGUAGE OverloadedStrings #-} + +-- Program that runs a short SMTP session +-- with a server running on local port 2025. + +module Main where + +import Data.Monoid +import qualified Data.Text as T +import Network.BSD (getHostName) -- requires 'network' package +import Network.Mail.Assumpta.Text + +sampleMesg :: T.Text +sampleMesg = T.intercalate crlf [ + "Date: Tue, 21 Jan 2020 02:28:37 +0800" + , "To: neddie.seagoon@gmail.com" + , "From: jim.moriarty@gmail.com" + , "Subject: test Tue, 21 Jan 2020 02:28:37 +0800" + , "" + , "Sapristi nyuckoes!" + ] + +-- The sender and recipient supplied to the +-- SMTP server are what is used to route the +-- message; any 'To:' and 'From:' fields +-- in the message are completely ignored for this +-- purpose. +sender, recipient :: T.Text +sender = "somesender@mycorp.com" +recipient = "somerecipient@mozilla.org" + +main :: IO () +main = do + let + port = 2025 + hostname <- getHostName + print =<< runSmtp "localhost" port (do + expectGreeting + ehlo $ T.pack hostname + -- Properly, we should escape periods at the start of a + -- line. But we know there aren't any + sendRawMail sender [recipient] sampleMesg + quit) + + diff --git a/scripts/stack-test.sh b/scripts/stack-test.sh new file mode 100644 --- /dev/null +++ b/scripts/stack-test.sh @@ -0,0 +1,12 @@ +#!/usr/bin/env bash + +# run 'stack-only' tests with some resolver + +if [ "$#" -ne 1 ]; then + echo "expected one arg, a resolver to use (e.g. 'lts-11')" + exit 1 +fi + +export STACK_RESOLVER="$1" +stack --resolver="${STACK_RESOLVER}" test --flag assumpta:stack-based-tests + diff --git a/src/Network/Mail/Assumpta/ByteString.hs b/src/Network/Mail/Assumpta/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Assumpta/ByteString.hs @@ -0,0 +1,309 @@ + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ >= 801 +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif + +{-# OPTIONS_HADDOCK show-extensions #-} + +{- | + +Communicate with SMTP servers using raw 'ByteString's, using +the infrastructure of the + +package. + +This module does not validate that your bytestrings +satisfy the requirements of the relevant RFCs -- see the note in +"Network.Mail.Assumpta.MonadSmtp#permissiblecharacters" +about "permissible characters". In general, unless you are using +an SMTP extension, your bytestrings must be 7-bit clean ASCII. + +== Example code + +Short example (which will work if you have an SMTP server +running on local port 2025): +(see the + +directory for a copy of the code): + +> {-# LANGUAGE OverloadedStrings #-} +> +> -- Program that runs a short SMTP session +> -- with a server running on local port 2025. +> +> module Main where +> +> import Data.Monoid +> import qualified Data.ByteString.Char8 as BS +> import qualified Data.Text as T +> import qualified Data.Text.Encoding as TE +> import Network.BSD (getHostName) -- requires 'network' package +> import Network.Mail.Assumpta.ByteString as M +> +> sampleMesg :: BS.ByteString +> sampleMesg = BS.intercalate crlf [ +> "Date: Tue, 21 Jan 2020 02:28:37 +0800" +> , "To: neddie.seagoon@gmail.com" +> , "From: jim.moriarty@gmail.com" +> , "Subject: test Tue, 21 Jan 2020 02:28:37 +0800" +> , "" +> , "Sapristi nyuckoes!" +> ] +> +> -- The sender and recipient supplied to the +> -- SMTP server are what is used to route the +> -- message; any 'To:' and 'From:' fields +> -- in the message are completely ignored for this +> -- purpose. +> sender, recipient :: BS.ByteString +> sender = "somesender@mycorp.com" +> recipient = "somerecipient@mozilla.org" +> +> main :: IO () +> main = do +> let toBinary = TE.encodeUtf8 . T.pack +> port = 2025 +> hostname <- getHostName +> print =<< runSmtp "localhost" port (do +> expectGreeting +> ehlo $ toBinary hostname +> -- Properly, we should escape periods at the start of a +> -- line. But we know there aren't any +> sendRawMail sender [recipient] sampleMesg +> quit) + +== Alternatives to "connection" + +If you want to use other network libraries besides +, +it should be pretty straightforward to adapt the code here. + +If you want to use stream-like IO, one possibility is +the package, +which provides Conduit-based sources and sinks on top of "Network.Connection". + + +-} + +module Network.Mail.Assumpta.ByteString + ( + -- * Run Smtp actions + -- | Run actions in the 'MonadSmtp' monad. + runSmtp + , runSecureSmtp + , runSmtpWithParams + , runSmtpHandle + -- * MonadError variants + -- | Instead of returning an Either, these run in MonadError -- + -- thus the caller can specialize them to a 'Maybe', 'Either', + -- or some other 'MonadError' instance as desired. + , runSmtp' + , runSecureSmtp' + , runSmtpWithParams' + , runSmtpHandle' + -- * SMTP commands + -- | Functions for sending commands + -- to an SMTP server. In general, these are wrappers around + -- 'command' and 'expect' -- they send some command, + -- and try to parse a response (throwing an 'SmtpError' + -- on failure). + , helo + , ehlo + , mailFrom + , rcptTo + , data_ + , noop + , quit + , rset + , startTLS + , expn + , vrfy + , help + , Smtp.sendRawMail + -- * Server responses + , expect + , expectGreeting + -- * Low-level operations and types + , sendLine + , command + , Reply + , ReplyLine(..) + , ReplyCode + , SmtpError(..) + -- * Monad transformer + -- | A monad transformer, 'SmtpT', which provides the ability to + -- send SMTP commands and parse replies, together with operations + -- on the transformer. + , SmtpT + , Smtp + , liftSmtpT + , mapSmtpT + -- * Network operations + -- | Network operations based around 'Handle', + -- using the + -- + -- package. + , open + , openTls + , openParams + , close + , withHandle + , withSecureHandle + , withHandleParams + , HostName + , Port + , Handle(..) + , defaultTLSSettings + -- * Utility functions + , rethrow + , mkParams + , toIOError + , crlf + ) + where + +import Control.Monad.Catch (MonadMask) +import Control.Monad.Except +import qualified Network.Connection as C + +import Network.Mail.Assumpta.Internal.Net +import Network.Mail.Assumpta.MonadSmtp as Smtp +import qualified Network.Mail.Assumpta.Trans.Smtp as T +import Network.Mail.Assumpta.Trans.Smtp hiding ( SmtpT(..) + , runSmtpEither + , rethrow + , runSmtp, open + , close ) + + +-- -- +-- Specialization of monad transformer to Handle + +-- | Smtp monad transformer. A specialization to 'Handle' +-- of the more general SmtpT type in the +-- +-- package. +type SmtpT = T.SmtpT Handle + +-- | Smtp actions in the IO monad. +type Smtp = SmtpT IO + +-- base funcs + +-- | @runSmtpHandle h a@ +-- +-- Run some 'Smtp' action @a@ on a 'Handle' @h@, +-- and return the result as an 'Either'. +runSmtpHandle :: + Handle -> Smtp a -> IO (Either SmtpError a) +runSmtpHandle = T.runSmtpEither + +-- | @runSmtpHandle h a@ +-- +-- Run some 'Smtp' action @a@ on a 'Handle' @h@, +-- and return the result as a 'MonadError'. +-- +-- Like 'runSmtpHandle' but generalized to 'MonadError'. +runSmtpHandle' :: + (MonadError SmtpError m, MonadIO m) => + Handle -> SmtpT m a -> m a +runSmtpHandle' = T.runSmtp + + + + +-- | @runSmtp hostname port a@ +-- +-- Open a connection to the specified @hostname@ and @port@, +-- run some 'Smtp' action @a@ with it, then +-- close, returning the result as an 'Either'. +runSmtp :: + HostName -> Int -> Smtp a -> IO (Either SmtpError a) +runSmtp host port a = + withHandle host port (`runSmtpHandle` a) + +-- | @runSmtp' host port a@ +-- +-- Like 'runSmtp', but generalized to 'MonadError'. +runSmtp' :: + (MonadMask m, MonadIO m, MonadError SmtpError m) => + HostName -> Port -> SmtpT m b -> m b +runSmtp' host port a = + withHandle host port (`runSmtpHandle'` a) + +-- | @runSecureSmtp hostname port a@ +-- +-- Open a secure TLS connection to the specified @hostname@ and @port@, +-- run some 'Smtp' action @a@ with it, then +-- close, returning the result as an 'Either'. +-- +-- Uses the default TLS settings, 'defaultTLSSettings'. For +-- more control, use 'runSmtpWithParams'. +runSecureSmtp :: + HostName -> Int -> Smtp a -> IO (Either SmtpError a) +runSecureSmtp host port a = + let params = (mkParams host port) { + C.connectionUseSecure = Just defaultTLSSettings + } + in runSmtpWithParams params a + +-- | @runSecureSmtp' host port a@ +-- +-- Like 'runSecureSmtp', but generalized to 'MonadError'. +runSecureSmtp' :: + (MonadMask m, MonadIO m, MonadError SmtpError m) => + HostName -> Int -> SmtpT m b -> m b +runSecureSmtp' host port a = + let params = (mkParams host port) { + C.connectionUseSecure = Just defaultTLSSettings + } + in runSmtpWithParams' params a + + +-- | @runSmtpWithParams params a@ +-- +-- Like 'runSmtp', but providing more control -- +-- the actions are run using the specified connection +-- parameters (hostname, port, TLS settings, etc.). +runSmtpWithParams :: + C.ConnectionParams -> Smtp a -> IO (Either SmtpError a) +runSmtpWithParams p a = + withHandleParams p (`runSmtpHandle` a) + + +-- | @runSmtpWithParams' params a@ +-- +-- Like 'runSmtpWithParams', but generalized to 'MonadError'. +runSmtpWithParams' :: + (MonadMask m, MonadIO m, MonadError SmtpError m) => + C.ConnectionParams -> SmtpT m b -> m b +runSmtpWithParams' p a = + withHandleParams p (`runSmtpHandle'` a) + +-- -- | @runSmtpT h a@ +-- +-- Given some 'Handle' @h@ and an 'SmtpT' action @a@, +-- run the action +-- and return the result as an 'Either'. +--runSmtpT' :: +-- MonadIO m => +-- Handle -> (forall n . Ass.MonadSmtp n => n a) -> m (Either SmtpError a) +--runSmtpT' = T.runSmtpEither + + +-- | Convenience function: convert an 'SmtpError' into +-- an 'IOError'. +toIOError :: SmtpError -> IOError +toIOError ex = userError $ "smtp operation error: " ++ show ex + +-- | convenience function: re-throw an 'SmtpError' as an +-- exception in 'IO'. +rethrow :: Either SmtpError a -> IO a +rethrow = + either (ioError . toIOError) return + + diff --git a/src/Network/Mail/Assumpta/Internal/Net.hs b/src/Network/Mail/Assumpta/Internal/Net.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Assumpta/Internal/Net.hs @@ -0,0 +1,130 @@ + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +{- | + +Network operations using +the +package. + +-} + +module Network.Mail.Assumpta.Internal.Net + + where + +import Control.Monad.Catch (MonadMask) +import Control.Monad.IO.Class +import Data.Default (def) +import qualified Network.Connection as NC + +import Network.Mail.Assumpta.Connection as C + +-- -- +-- Network types and ops + +type Port = Int +type HostName = String + +-- | Network handle, containing enough +-- information to both communicate a connection, +-- and upgrade to TLS. +data Handle = Handle { + hConn :: !NC.Connection + , hContext :: !NC.ConnectionContext + } + +-- Implementation of 'Connection' using +-- the +-- package. +instance Connection Handle where + type Cstrt Handle = MonadIO + type Params Handle = NC.ConnectionParams + + open params = do ctx <- liftIO NC.initConnectionContext + conn <- liftIO $ NC.connectTo ctx params + return $ Handle conn ctx + close = liftIO . NC.connectionClose . hConn + + send h bs = liftIO $ NC.connectionPut (hConn h) bs + recv h = liftIO $ NC.connectionGet (hConn h) 2048 + + upgrade h = let conn = hConn h + ctx = hContext h + tls = defaultTLSSettings + in liftIO $ NC.connectionSetSecure ctx conn tls + +-- | default TLS settings +defaultTLSSettings :: NC.TLSSettings +defaultTLSSettings = def + +mkParams :: + HostName -> Int -> NC.ConnectionParams +mkParams hostname port = + NC.ConnectionParams { + NC.connectionHostname = hostname + , NC.connectionPort = fromIntegral port + , NC.connectionUseSecure = Nothing + , NC.connectionUseSocks = Nothing + } + +-- | Open a network 'Handle' with the specified 'NC.ConnectionParams' +openParams :: + MonadIO m => NC.ConnectionParams -> m Handle +openParams = + C.open + +-- | Open a network 'Handle' to the specified hostname and port +open :: MonadIO m => HostName -> Port -> m Handle +open host port = + let p = mkParams host port + in openParams p + + +-- | Open a secure network 'Handle' to the specified hostname and port +-- using the default TLS settings ('defaultTLSSettings') +openTls :: MonadIO m => HostName -> Port -> m Handle +openTls host port = + let p = (mkParams host port) { NC.connectionUseSecure = Just defaultTLSSettings } + in openParams p + +-- | Close a network 'Handle' +close :: MonadIO m => Handle -> m () +close = + C.close + +-- | @withHandleParams p a@ +-- +-- Given some parameters @p@ (hostname, port etc) for opening a 'Handle': +-- open a handle, run some action @a@ with it, then +-- close. +withHandleParams :: + (MonadMask m, MonadIO m) => NC.ConnectionParams -> (Handle -> m b) -> m b +withHandleParams = + C.withConnection + +-- | @withHandle hostname port a@ +-- +-- Open a 'Handle' to the specified @hostname@ and @port@, +-- run some action @a@ with it, then +-- close. +withHandle :: + (MonadMask m, MonadIO m) => HostName -> Port -> (Handle -> m b) -> m b +withHandle host port = + let p = mkParams host port + in withHandleParams p + +-- | @withSecureHandle hostname port a@ +-- +-- Open a secure 'Handle' to the specified @hostname@ and @port@, +-- run some action @a@ with it, then +-- close. +withSecureHandle :: + (MonadMask m, MonadIO m) => HostName -> Port -> (Handle -> m b) -> m b +withSecureHandle host port = + let p = (mkParams host port) { + NC.connectionUseSecure = Just defaultTLSSettings + } + in withHandleParams p + diff --git a/src/Network/Mail/Assumpta/String.hs b/src/Network/Mail/Assumpta/String.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Assumpta/String.hs @@ -0,0 +1,159 @@ + +{- | + +'String' versions of Smtp operations. + +This module does not validate that your strings +satisfy the requirements of the relevant RFCs -- see the note in +"Network.Mail.Assumpta.MonadSmtp#permissiblecharacters" +about "permissible characters". In general, unless you are using +an SMTP extension, your strings must consist of 7-bit clean ASCII. + +-} + +module Network.Mail.Assumpta.String + ( + -- * Run Smtp actions + -- | Run actions in the 'MonadSmtp' monad. + AT.runSmtp + , AT.runSecureSmtp + , AT.runSmtpWithParams + , AT.runSmtpHandle + -- * MonadError variants + -- | Instead of returning an Either, these run in MonadError -- + -- thus the caller can specialize them to a 'Maybe', 'Either', + -- or some other 'MonadError' instance as desired. + , AT.runSmtp' + , AT.runSecureSmtp' + , AT.runSmtpWithParams' + , AT.runSmtpHandle' + -- * SMTP commands + -- | Functions for sending commands + -- to an SMTP server. In general, these are wrappers around + -- 'command' and 'expect' -- they send some command, + -- and try to parse a response (throwing an 'SmtpError' + -- on failure). + -- See the "Network.Mail.Assumpta.ByteString" module for + -- documentation of each function. + , helo + , ehlo + , mailFrom + , rcptTo + , data_ + , AT.noop + , AT.quit + , AT.rset + , AT.startTLS + , expn + , vrfy + , help + , sendRawMail + -- * Server responses + , AT.expect + , AT.expectGreeting + -- * Low-level operations and types + , AT.command + , AT.Reply + , AT.ReplyLine(..) + , AT.ReplyCode + , AT.SmtpError(..) + -- * Monad transformer + -- | A monad transformer, 'SmtpT', which provides the ability to + -- send SMTP commands and parse replies, together with operations + -- on the transformer. + , AT.SmtpT + , AT.Smtp + , AT.liftSmtpT + , AT.mapSmtpT + -- * Network operations + , AT.open + , AT.openTls + , AT.openParams + , AT.close + , AT.withHandle + , AT.withSecureHandle + , AT.withHandleParams + , AT.HostName + , AT.Port + , AT.Handle(..) + , AT.defaultTLSSettings + , send + , sendLine + -- * Utility functions + , toCrLf + , AT.rethrow + , AT.mkParams + , AT.toIOError + , AT.crlf + , escapePeriods + ) + where + +import Data.Foldable (toList) +import Data.Monoid -- needed for early versions of Base +import qualified Data.Text as T + +import qualified Network.Mail.Assumpta.ByteString as ABS +import qualified Network.Mail.Assumpta.Text as AT + +import Network.Mail.Assumpta.MonadSmtp ( MonadSmtp ) +import qualified Network.Mail.Assumpta.MonadSmtp as M + +-- | See 'M.helo' +helo :: MonadSmtp m => String -> m () +helo = AT.helo . T.pack + +-- | See 'M.ehlo' +ehlo :: MonadSmtp m => String -> m () +ehlo = AT.ehlo . T.pack + +-- | See 'M.mailFrom' +mailFrom :: MonadSmtp m => String -> m () +mailFrom = AT.mailFrom . T.pack + +-- | See 'M.rcptTo' +rcptTo :: MonadSmtp m => String -> m () +rcptTo = AT.rcptTo . T.pack + +-- | See 'M.data_' +data_ :: MonadSmtp m => String -> m () +data_ = AT.data_ . T.pack + +-- | See 'M.expn' +expn :: MonadSmtp m => String -> m AT.Reply +expn = AT.expn . T.pack + +-- | See 'M.vrfy' +vrfy :: MonadSmtp m => String -> m AT.Reply +vrfy = AT.vrfy . T.pack + +help :: MonadSmtp m => Maybe String -> m AT.Reply +help = AT.help . fmap T.pack + +-- | See 'M.send' +send :: MonadSmtp m => String -> m () +send = AT.send . T.pack + +-- | See 'M.sendLine' +sendLine :: MonadSmtp m => String -> m () +sendLine = AT.sendLine . T.pack + +-- | replace newlines (@\'\\n'@) with crlf sequence (@\'\\r\\n'@). +toCrLf :: String -> String +toCrLf = T.unpack . AT.toCrLf . T.pack + +-- | Where a period ('.') character starts a (crlf-delimited) +-- line, replace it with two periods. +escapePeriods :: String -> String +escapePeriods = T.unpack . AT.escapePeriods . T.pack + +-- | see 'ABS.sendRawMail'. +sendRawMail :: + (MonadSmtp m, Foldable t) => String -> t String -> String -> m () +sendRawMail sender recipients message = + let sender' = T.pack sender + recipients' = map T.pack (toList recipients) + message' = T.pack message + in AT.sendRawMail sender' recipients' message' + + diff --git a/src/Network/Mail/Assumpta/Text.hs b/src/Network/Mail/Assumpta/Text.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Assumpta/Text.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | + +'Text' versions of Smtp operations. + +This module does not validate that your text +satisfies the requirements of the relevant RFCs -- see the note in +"Network.Mail.Assumpta.MonadSmtp#permissiblecharacters" +about "permissible characters". In general, unless you are using +an SMTP extension, your text must consist of 7-bit clean ASCII. + +== Example code + +Short example (which will work if you have an SMTP server +running on local port 2025): +(see the + +directory for a copy of the code): + +> {-# LANGUAGE OverloadedStrings #-} +> +> -- Program that runs a short SMTP session +> -- with a server running on local port 2025. +> +> module Main where +> +> import Data.Monoid +> import qualified Data.Text as T +> import Network.BSD (getHostName) -- requires 'network' package +> import Network.Mail.Assumpta.Text +> +> sampleMesg :: T.Text +> sampleMesg = T.intercalate crlf [ +> "Date: Tue, 21 Jan 2020 02:28:37 +0800" +> , "To: neddie.seagoon@gmail.com" +> , "From: jim.moriarty@gmail.com" +> , "Subject: test Tue, 21 Jan 2020 02:28:37 +0800" +> , "" +> , "Sapristi nyuckoes!" +> ] +> +> -- The sender and recipient supplied to the +> -- SMTP server are what is used to route the +> -- message; any 'To:' and 'From:' fields +> -- in the message are completely ignored for this +> -- purpose. +> sender, recipient :: T.Text +> sender = "somesender@mycorp.com" +> recipient = "somerecipient@mozilla.org" +> +> main :: IO () +> main = do +> let +> port = 2025 +> hostname <- getHostName +> print =<< runSmtp "localhost" port (do +> expectGreeting +> ehlo $ T.pack hostname +> -- Properly, we should escape periods at the start of a +> -- line. But we know there aren't any +> sendRawMail sender [recipient] sampleMesg +> quit) + +== Alternatives to "connection" + +If you want to use other network libraries besides +, +it should be pretty straightforward to adapt the code here. + +If you want to use stream-like IO, one possibility is +the package, +which provides Conduit-based sources and sinks on top of "Network.Connection". + + +-} + +module Network.Mail.Assumpta.Text + ( + -- * Run Smtp actions + -- | Run actions in the 'MonadSmtp' monad. + ABS.runSmtp + , ABS.runSecureSmtp + , ABS.runSmtpWithParams + , ABS.runSmtpHandle + -- * MonadError variants + -- | Instead of returning an Either, these run in MonadError -- + -- thus the caller can specialize them to a 'Maybe', 'Either', + -- or some other 'MonadError' instance as desired. + , ABS.runSmtp' + , ABS.runSecureSmtp' + , ABS.runSmtpWithParams' + , ABS.runSmtpHandle' + -- * SMTP commands + -- | Functions for sending commands + -- to an SMTP server. In general, these are wrappers around + -- 'command' and 'expect' -- they send some command, + -- and try to parse a response (throwing an 'SmtpError' + -- on failure). + -- See the "Network.Mail.Assumpta.ByteString" module for + -- documentation of each function. + , helo + , ehlo + , mailFrom + , rcptTo + , data_ + , ABS.noop + , ABS.quit + , ABS.rset + , ABS.startTLS + , expn + , vrfy + , help + , sendRawMail + , simpleMail + -- * Server responses + , ABS.expect + , ABS.expectGreeting + -- * Low-level operations and types + , ABS.command + , ABS.Reply + , ABS.ReplyLine(..) + , ABS.ReplyCode + , ABS.SmtpError(..) + -- * Monad transformer + -- | A monad transformer, 'SmtpT', which provides the ability to + -- send SMTP commands and parse replies, together with operations + -- on the transformer. + , ABS.SmtpT + , ABS.Smtp + , ABS.liftSmtpT + , ABS.mapSmtpT + -- * Network operations + , ABS.open + , ABS.openTls + , ABS.openParams + , ABS.close + , ABS.withHandle + , ABS.withSecureHandle + , ABS.withHandleParams + , ABS.HostName + , ABS.Port + , ABS.Handle(..) + , ABS.defaultTLSSettings + , send + , sendLine + -- * Utility functions + , toCrLf + , ABS.rethrow + , ABS.mkParams + , ABS.toIOError + , ABS.crlf + , escapePeriods + ) + where + +import Data.ByteString.Lazy (toStrict) +import Data.Foldable (toList) +import Data.Monoid -- needed for early versions of Base +import qualified Data.Text as T +import Data.Text ( Text ) +import Data.Text.Encoding ( encodeUtf8, decodeUtf8 ) +import Data.Text.Lazy (fromStrict) +import qualified Network.Mail.Mime as MM ( Address(..), simpleMail + , renderMail' ) + +import qualified Network.Mail.Assumpta.ByteString as ABS + +import Network.Mail.Assumpta.MonadSmtp ( MonadSmtp ) +import qualified Network.Mail.Assumpta.MonadSmtp as M + +-- | See 'M.helo' +helo :: MonadSmtp m => Text -> m () +helo = M.helo . encodeUtf8 + +-- | See 'M.ehlo' +ehlo :: MonadSmtp m => Text -> m () +ehlo = M.ehlo . encodeUtf8 + +-- | See 'M.mailFrom' +mailFrom :: MonadSmtp m => Text -> m () +mailFrom = M.mailFrom . encodeUtf8 + +-- | See 'M.rcptTo' +rcptTo :: MonadSmtp m => Text -> m () +rcptTo = M.rcptTo . encodeUtf8 + +-- | See 'M.data_' +data_ :: MonadSmtp m => Text -> m () +data_ = M.data_ . encodeUtf8 + +-- | See 'M.expn' +expn :: MonadSmtp m => Text -> m M.Reply +expn = M.expn . encodeUtf8 + +-- | See 'M.vrfy' +vrfy :: MonadSmtp m => Text -> m M.Reply +vrfy = M.vrfy . encodeUtf8 + +-- | See 'M.help' +help :: MonadSmtp m => Maybe Text -> m M.Reply +help = M.help . fmap encodeUtf8 + + +-- | See 'M.send' +send :: MonadSmtp m => Text -> m () +send = M.send . encodeUtf8 + +-- | See 'M.sendLine' +sendLine :: MonadSmtp m => Text -> m () +sendLine = M.sendLine . encodeUtf8 + +-- | replace newlines (@\'\\n'@) with crlf sequence (@\'\\r\\n'@). +toCrLf :: Text -> Text +toCrLf txt = T.intercalate M.crlf $ T.lines txt + +-- | Where a period ('.') character starts a (crlf-delimited) +-- line, replace it with two periods. +escapePeriods :: Text -> Text +escapePeriods txt = + T.concat $ map escapeLine $ T.splitOn M.crlf txt + where + escapeLine t = + if "." `T.isPrefixOf` t + then "." <> t + else t + +-- | see 'ABS.sendRawMail'. +sendRawMail :: + (MonadSmtp m, Foldable t) => Text -> t Text -> Text -> m () +sendRawMail sender recipients message = + let sender' = encodeUtf8 sender + recipients' = map encodeUtf8 (toList recipients) + message' = encodeUtf8 message + in ABS.sendRawMail sender' recipients' message' + + +-- | A simple interface for generating an email with HTML and plain-text +-- alternatives and some file attachments and sending it via an +-- SMTP server. +-- +-- Uses lazy IO for reading in the attachment contents. Simple wrapper +-- around 'MM.renderMail''. /Caution/: Not tested, use with care. +-- Likely to change. +-- +-- sample use: +-- +-- @ +-- > import qualified Network.Mail.Mime as MM +-- > :set -XOverloadedStrings +-- > :{ +-- let addr = MM.Address (Just "joe") "joe@nowhere" +-- subj = "a test subject" +-- body = "a test body" +-- > :} +-- > simpleMail addr addr subj body "" [] "myserver.mydomain.com" "mail.yourserver.org" 2025 +-- @ +{-# WARNING simpleMail "experimental, likely to change" #-} +simpleMail :: MM.Address -- ^ to + -> MM.Address -- ^ from + -> T.Text -- ^ subject + -> T.Text -- ^ plain body + -> T.Text -- ^ HTML body + -> [(T.Text, FilePath)] -- ^ content type and path of attachments + -> String -- ^ qualified name of local host + -> String -- ^ SMTP server to connect to + -> Int -- ^ Port of SMTP server + -> IO (T.Text, Either M.SmtpError ()) +simpleMail to from subject plainBody htmlBody attachments localHost server port = + do + let plainBody' = fromStrict plainBody + htmlBody' = fromStrict htmlBody + mail <- escape . toStrict <$> (MM.renderMail' =<< + MM.simpleMail to from subject plainBody' htmlBody' attachments) + let mail' = if crlf `T.isSuffixOf` mail + then mail <> "." <> crlf + else mail <> crlf <> "." <> crlf + to' = MM.addressEmail to + from' = MM.addressEmail from + res <- ABS.runSmtp server port $ do + ABS.expectGreeting + ehlo $ T.pack localHost + sendRawMail from' [to'] mail' + ABS.quit + return (mail, res) + where + escape = escapePeriods . toCrLf . decodeUtf8 + crlf = ABS.crlf + +----testX :: IO (Either SmtpError ()) +--testX = +-- let addr = MM.Address (Just "joe") "joe@place" +-- subj = "a test subj" +-- body = "a test body" +-- in simpleMail addr addr subj body "" [] "myserver.lan" "localhost" 2025 + + + + diff --git a/stack-lts-12.26.yaml b/stack-lts-12.26.yaml new file mode 100644 --- /dev/null +++ b/stack-lts-12.26.yaml @@ -0,0 +1,7 @@ +resolver: lts-12.26 + +packages: +- . + +extra-deps: +- assumpta-core-0.1.0.2@sha256:256ef9a9450c40b0623cfe9f222b32733055a5aee4e4a6658d339aef14f9e3fc diff --git a/test-hspec/Network/Mail/Assumpta/ByteStringSpec.hs b/test-hspec/Network/Mail/Assumpta/ByteStringSpec.hs new file mode 100644 --- /dev/null +++ b/test-hspec/Network/Mail/Assumpta/ByteStringSpec.hs @@ -0,0 +1,175 @@ + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +module Network.Mail.Assumpta.ByteStringSpec + (main, spec) + where + +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.IO (propertyIO) + +import Control.Concurrent +import Control.Exception (bracket, evaluate) +import Control.Monad + +import qualified Data.ByteString.Char8 as BSC +import Data.ByteString.Char8 ( ByteString ) +import Data.Monoid -- for early base + +import Network.Socket as N hiding (recv) +import Network.Socket.ByteString as N (sendAll, recv) + + +import Network.Mail.Assumpta.ByteString + +{-# ANN module ("HLint: ignore Use camelCase" :: String) #-} + +-- oops +deriving instance Eq ReplyLine +deriving instance Eq SmtpError + +-- .. probably shouldn't churn through *quite* so many sockets +-- so fast - but I haven't run out, so a pool doesn't seem +-- necessary yet. +mkServerSoc :: IO (N.Socket, N.PortNumber) +mkServerSoc = do + -- wildcard port + let addr = N.SockAddrInet N.aNY_PORT N.iNADDR_ANY + soc <- N.socket N.AF_INET N.Stream N.defaultProtocol + N.bind soc addr + N.listen soc 5 + -- find out what port we got + port <- N.socketPort soc + return (soc,port) + +-- | @runSmtpWithServer a replies@ +-- +-- spin up a TCP server, run 'runSmtp' to send +-- commands to it, return result, plus requests received +-- by server. @replies@ are the canned responses +-- the server is to make. +-- +-- The client needs to 'expect' something to start +-- with (i.e. the server goes first), else +-- things are likely to get out of sync. +runSmtpWithServer :: + Smtp a -> [ByteString] -> IO (Either SmtpError a, ByteString) +runSmtpWithServer commands replies = do + (soc, port) <- mkServerSoc + mRequestsRecvd <- newEmptyMVar + -- server + void $ forkIO $ + let acquire = fst <$> N.accept soc + release = N.close + in bracket acquire release $ \soc' -> do + requests <- forM replies $ \reply -> do + N.sendAll soc' $ reply <> crlf + N.recv soc' 4096 + -- ??? needed?? + requests <- evaluate requests + -- + putMVar mRequestsRecvd $ mconcat requests + clientRes <- runSmtp "localhost" (fromIntegral port) commands + -- return results + requestsRcvd <- readMVar mRequestsRecvd + return (clientRes, requestsRcvd) + +-- make a server test case out of description, cmds to run, etc +mkSmtpTestCase :: + (Show b, Eq b) => + String + -> Smtp b + -> [ByteString] + -> (Either SmtpError b, ByteString) + -> SpecWith () +mkSmtpTestCase testCaseName cmds serverReplies expectedResult = + context ("when run with test case " <> show testCaseName) $ + it "should send expected bytes & return expected result" $ + runSmtpWithServer cmds serverReplies `shouldReturn` expectedResult + +-- | when the client disconnects, the server should get a +-- final empty bytestring +smtpTestCases :: [SpecWith ()] +smtpTestCases = [ + mkSmtpTestCase + "helo then quit" + -- cmds + (do expectGreeting + helo "myhost" + quit ) + -- responses + [ "220 hi there" + , "250 OK" + , "221 Bye" + ] + -- expect + (Right (), mconcat ["HELO myhost\r\n" + ,"QUIT\r\n"]) + + , mkSmtpTestCase + "improper greeting" + -- cmds + expectGreeting + -- responses + [ "250 OK" -- bad greeting + ] + -- expect + (Left (UnexpectedResponse "220" [ReplyLine 250 "OK"]), "") + + , mkSmtpTestCase + "using sendRawMail" + -- cmds + (do expectGreeting + sendRawMail "somesender" ["somerecipt"] "some body text" + quit ) + -- responses + [ "220 hi there" + , "250 OK" + , "250 OK" + , "354 End data with ." + , "250 OK" + , "221 Bye" + ] + -- expect + (Right (), BSC.intercalate crlf [ + "MAIL FROM:" + , "RCPT TO:" + , "DATA" + , "some body text" + , "." + , "QUIT\r\n"]) + + ] + +data_Spec :: SpecWith () +data_Spec = + describe "data_ function" $ + it "should pass on its content unchanged" $ property $ + \(NonEmpty someData) -> ioProperty $ do + let someData' = BSC.pack someData + cmds = do expectGreeting + data_ $ someData' <> crlf + serverReplies = [ + "220 hi there" + , "354 End data with ." + , "250 OK" + ] + res <- runSmtpWithServer cmds serverReplies + return $ propertyIO $ + res `shouldBe` (Right (), "DATA\r\n" <> someData' <> "\r\n") + + +-- `main` is here so that this module can be run from GHCi on its own. It is +-- not needed for automatic spec discovery. +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "runSmtp" $ + sequence_ smtpTestCases + data_Spec + diff --git a/test-hspec/hspec-tests.hs b/test-hspec/hspec-tests.hs new file mode 100644 --- /dev/null +++ b/test-hspec/hspec-tests.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test-other/compile-examples.hs b/test-other/compile-examples.hs new file mode 100644 --- /dev/null +++ b/test-other/compile-examples.hs @@ -0,0 +1,80 @@ + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +import Control.Monad +import Data.Char as Ch +import Data.Maybe +import Data.Monoid +import Shelly as Sh +import qualified Data.Text as T +import System.IO + +-- Requires the test-doctests flag to be enabled, +-- and the STACK_RESOLVER environment variable to +-- be defined (specifying a resolver to use, e.g. +-- "lts-14"). +-- +default (T.Text) + +{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} +{-# ANN module ("HLint: ignore Use camelCase" :: String) #-} + +isHaskSource :: Sh.FilePath -> Bool +isHaskSource p = "hs" `hasExt` p + +basename :: Sh.FilePath -> Sh.FilePath -> Sh Sh.FilePath +basename dir file = + relativeTo dir file + +baseNameSatisfies :: + (T.Text -> b) -> Sh.FilePath -> Sh.FilePath -> Sh b +baseNameSatisfies pred basedir file = pred . toTextIgnore <$> basename basedir file + +-- is stack on the path +we_must_have_stack :: Sh () +we_must_have_stack = + unlessM (isJust <$> which "stack") $ do + echo "'stack' binary not found on path, exiting" + terror "abort! abort!" + +-- are we running as part of 'stack test'? +-- If so, we can assume the library has been +-- built and is available to us. +we_must_be_run_by_stack :: Sh () +we_must_be_run_by_stack = + unlessM (isJust <$> get_env "STACK_EXE") $ + terror "STACK_EXE env var not set" + +get_stack_resolver :: Sh T.Text +get_stack_resolver = + get_env "STACK_RESOLVER" >>= \case + Nothing -> terror "STACK_RESOLVER env var not set, exiting" + Just res -> return res + +main :: IO () +main = + do + let examplesDir = "examples" + hSetBuffering stdout LineBuffering + shelly $ verbosely $ do + echo "\n\n==================" + echo "Compiling Examples" + echo "==================\n" + stack_resolver <- get_stack_resolver + we_must_have_stack + we_must_be_run_by_stack + hsFiles <- (filter isHaskSource <$> ls examplesDir) >>= + filterM (baseNameSatisfies startsWithLetter examplesDir) + + forM_ hsFiles $ \hsFile -> do + let hsFile' = toTextIgnore hsFile + echo $ "Compiling " <> hsFile' <> "\n" + run "stack" ["ghc", "--resolver=" <> stack_resolver + , "--", "--make", toTextIgnore hsFile] + + where + startsWithLetter = Ch.isLetter . T.head +