From 985974c264804ff788b3b5242fef707d4b7fa9a6 Mon Sep 17 00:00:00 2001
From: evuez <julien@mulga.net>
Date: Mon, 1 Apr 2024 15:17:30 +0200
Subject: Initial commit
---
.ghci | 7 +
.gitignore | 2 +
COPYING | 373 +++++++++++++++++++++++++++++++++++++++++++++++++++++
Makefile | 16 +++
README.md | 22 ++++
app/Main.hs | 44 +++++++
flake.lock | 80 ++++++++++++
flake.nix | 25 ++++
fourmolu.yaml | 5 +
src/Cache.hs | 46 +++++++
src/Common.hs | 82 ++++++++++++
src/Common/Mime.hs | 23 ++++
src/Html.hs | 88 +++++++++++++
src/Http.hs | 75 +++++++++++
src/Intro.hs | 50 +++++++
src/Mail.hs | 39 ++++++
src/Mail/Header.hs | 45 +++++++
src/Mail/Parser.hs | 136 +++++++++++++++++++
src/Queue.hs | 65 ++++++++++
src/Smtp.hs | 102 +++++++++++++++
src/Tcp.hs | 50 +++++++
src/Template.hs | 67 ++++++++++
webmaild.cabal | 71 ++++++++++
23 files changed, 1513 insertions(+)
create mode 100644 .ghci
create mode 100644 .gitignore
create mode 100644 COPYING
create mode 100644 Makefile
create mode 100644 README.md
create mode 100644 app/Main.hs
create mode 100644 flake.lock
create mode 100644 flake.nix
create mode 100644 fourmolu.yaml
create mode 100644 src/Cache.hs
create mode 100644 src/Common.hs
create mode 100644 src/Common/Mime.hs
create mode 100644 src/Html.hs
create mode 100644 src/Http.hs
create mode 100644 src/Intro.hs
create mode 100644 src/Mail.hs
create mode 100644 src/Mail/Header.hs
create mode 100644 src/Mail/Parser.hs
create mode 100644 src/Queue.hs
create mode 100644 src/Smtp.hs
create mode 100644 src/Tcp.hs
create mode 100644 src/Template.hs
create mode 100644 webmaild.cabal
diff --git a/.ghci b/.ghci
new file mode 100644
index 0000000..5fae2b2
--- /dev/null
+++ b/.ghci
@@ -0,0 +1,7 @@
+:set -fno-code
+:set -ferror-spans -freverse-errors -fprint-expanded-synonyms
+
+:def hlint const . return $ return $ ":! hlint \"src\""
+
+:set -isrc
+:load app/Main.hs
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..6d7e2df
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,2 @@
+dist-newstyle/
+result
diff --git a/COPYING b/COPYING
new file mode 100644
index 0000000..d0a1fa1
--- /dev/null
+++ b/COPYING
@@ -0,0 +1,373 @@
+Mozilla Public License Version 2.0
+==================================
+
+1. Definitions
+--------------
+
+1.1. "Contributor"
+ means each individual or legal entity that creates, contributes to
+ the creation of, or owns Covered Software.
+
+1.2. "Contributor Version"
+ means the combination of the Contributions of others (if any) used
+ by a Contributor and that particular Contributor's Contribution.
+
+1.3. "Contribution"
+ means Covered Software of a particular Contributor.
+
+1.4. "Covered Software"
+ means Source Code Form to which the initial Contributor has attached
+ the notice in Exhibit A, the Executable Form of such Source Code
+ Form, and Modifications of such Source Code Form, in each case
+ including portions thereof.
+
+1.5. "Incompatible With Secondary Licenses"
+ means
+
+ (a) that the initial Contributor has attached the notice described
+ in Exhibit B to the Covered Software; or
+
+ (b) that the Covered Software was made available under the terms of
+ version 1.1 or earlier of the License, but not also under the
+ terms of a Secondary License.
+
+1.6. "Executable Form"
+ means any form of the work other than Source Code Form.
+
+1.7. "Larger Work"
+ means a work that combines Covered Software with other material, in
+ a separate file or files, that is not Covered Software.
+
+1.8. "License"
+ means this document.
+
+1.9. "Licensable"
+ means having the right to grant, to the maximum extent possible,
+ whether at the time of the initial grant or subsequently, any and
+ all of the rights conveyed by this License.
+
+1.10. "Modifications"
+ means any of the following:
+
+ (a) any file in Source Code Form that results from an addition to,
+ deletion from, or modification of the contents of Covered
+ Software; or
+
+ (b) any new file in Source Code Form that contains any Covered
+ Software.
+
+1.11. "Patent Claims" of a Contributor
+ means any patent claim(s), including without limitation, method,
+ process, and apparatus claims, in any patent Licensable by such
+ Contributor that would be infringed, but for the grant of the
+ License, by the making, using, selling, offering for sale, having
+ made, import, or transfer of either its Contributions or its
+ Contributor Version.
+
+1.12. "Secondary License"
+ means either the GNU General Public License, Version 2.0, the GNU
+ Lesser General Public License, Version 2.1, the GNU Affero General
+ Public License, Version 3.0, or any later versions of those
+ licenses.
+
+1.13. "Source Code Form"
+ means the form of the work preferred for making modifications.
+
+1.14. "You" (or "Your")
+ means an individual or a legal entity exercising rights under this
+ License. For legal entities, "You" includes any entity that
+ controls, is controlled by, or is under common control with You. For
+ purposes of this definition, "control" means (a) the power, direct
+ or indirect, to cause the direction or management of such entity,
+ whether by contract or otherwise, or (b) ownership of more than
+ fifty percent (50%) of the outstanding shares or beneficial
+ ownership of such entity.
+
+2. License Grants and Conditions
+--------------------------------
+
+2.1. Grants
+
+Each Contributor hereby grants You a world-wide, royalty-free,
+non-exclusive license:
+
+(a) under intellectual property rights (other than patent or trademark)
+ Licensable by such Contributor to use, reproduce, make available,
+ modify, display, perform, distribute, and otherwise exploit its
+ Contributions, either on an unmodified basis, with Modifications, or
+ as part of a Larger Work; and
+
+(b) under Patent Claims of such Contributor to make, use, sell, offer
+ for sale, have made, import, and otherwise transfer either its
+ Contributions or its Contributor Version.
+
+2.2. Effective Date
+
+The licenses granted in Section 2.1 with respect to any Contribution
+become effective for each Contribution on the date the Contributor first
+distributes such Contribution.
+
+2.3. Limitations on Grant Scope
+
+The licenses granted in this Section 2 are the only rights granted under
+this License. No additional rights or licenses will be implied from the
+distribution or licensing of Covered Software under this License.
+Notwithstanding Section 2.1(b) above, no patent license is granted by a
+Contributor:
+
+(a) for any code that a Contributor has removed from Covered Software;
+ or
+
+(b) for infringements caused by: (i) Your and any other third party's
+ modifications of Covered Software, or (ii) the combination of its
+ Contributions with other software (except as part of its Contributor
+ Version); or
+
+(c) under Patent Claims infringed by Covered Software in the absence of
+ its Contributions.
+
+This License does not grant any rights in the trademarks, service marks,
+or logos of any Contributor (except as may be necessary to comply with
+the notice requirements in Section 3.4).
+
+2.4. Subsequent Licenses
+
+No Contributor makes additional grants as a result of Your choice to
+distribute the Covered Software under a subsequent version of this
+License (see Section 10.2) or under the terms of a Secondary License (if
+permitted under the terms of Section 3.3).
+
+2.5. Representation
+
+Each Contributor represents that the Contributor believes its
+Contributions are its original creation(s) or it has sufficient rights
+to grant the rights to its Contributions conveyed by this License.
+
+2.6. Fair Use
+
+This License is not intended to limit any rights You have under
+applicable copyright doctrines of fair use, fair dealing, or other
+equivalents.
+
+2.7. Conditions
+
+Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted
+in Section 2.1.
+
+3. Responsibilities
+-------------------
+
+3.1. Distribution of Source Form
+
+All distribution of Covered Software in Source Code Form, including any
+Modifications that You create or to which You contribute, must be under
+the terms of this License. You must inform recipients that the Source
+Code Form of the Covered Software is governed by the terms of this
+License, and how they can obtain a copy of this License. You may not
+attempt to alter or restrict the recipients' rights in the Source Code
+Form.
+
+3.2. Distribution of Executable Form
+
+If You distribute Covered Software in Executable Form then:
+
+(a) such Covered Software must also be made available in Source Code
+ Form, as described in Section 3.1, and You must inform recipients of
+ the Executable Form how they can obtain a copy of such Source Code
+ Form by reasonable means in a timely manner, at a charge no more
+ than the cost of distribution to the recipient; and
+
+(b) You may distribute such Executable Form under the terms of this
+ License, or sublicense it under different terms, provided that the
+ license for the Executable Form does not attempt to limit or alter
+ the recipients' rights in the Source Code Form under this License.
+
+3.3. Distribution of a Larger Work
+
+You may create and distribute a Larger Work under terms of Your choice,
+provided that You also comply with the requirements of this License for
+the Covered Software. If the Larger Work is a combination of Covered
+Software with a work governed by one or more Secondary Licenses, and the
+Covered Software is not Incompatible With Secondary Licenses, this
+License permits You to additionally distribute such Covered Software
+under the terms of such Secondary License(s), so that the recipient of
+the Larger Work may, at their option, further distribute the Covered
+Software under the terms of either this License or such Secondary
+License(s).
+
+3.4. Notices
+
+You may not remove or alter the substance of any license notices
+(including copyright notices, patent notices, disclaimers of warranty,
+or limitations of liability) contained within the Source Code Form of
+the Covered Software, except that You may alter any license notices to
+the extent required to remedy known factual inaccuracies.
+
+3.5. Application of Additional Terms
+
+You may choose to offer, and to charge a fee for, warranty, support,
+indemnity or liability obligations to one or more recipients of Covered
+Software. However, You may do so only on Your own behalf, and not on
+behalf of any Contributor. You must make it absolutely clear that any
+such warranty, support, indemnity, or liability obligation is offered by
+You alone, and You hereby agree to indemnify every Contributor for any
+liability incurred by such Contributor as a result of warranty, support,
+indemnity or liability terms You offer. You may include additional
+disclaimers of warranty and limitations of liability specific to any
+jurisdiction.
+
+4. Inability to Comply Due to Statute or Regulation
+---------------------------------------------------
+
+If it is impossible for You to comply with any of the terms of this
+License with respect to some or all of the Covered Software due to
+statute, judicial order, or regulation then You must: (a) comply with
+the terms of this License to the maximum extent possible; and (b)
+describe the limitations and the code they affect. Such description must
+be placed in a text file included with all distributions of the Covered
+Software under this License. Except to the extent prohibited by statute
+or regulation, such description must be sufficiently detailed for a
+recipient of ordinary skill to be able to understand it.
+
+5. Termination
+--------------
+
+5.1. The rights granted under this License will terminate automatically
+if You fail to comply with any of its terms. However, if You become
+compliant, then the rights granted under this License from a particular
+Contributor are reinstated (a) provisionally, unless and until such
+Contributor explicitly and finally terminates Your grants, and (b) on an
+ongoing basis, if such Contributor fails to notify You of the
+non-compliance by some reasonable means prior to 60 days after You have
+come back into compliance. Moreover, Your grants from a particular
+Contributor are reinstated on an ongoing basis if such Contributor
+notifies You of the non-compliance by some reasonable means, this is the
+first time You have received notice of non-compliance with this License
+from such Contributor, and You become compliant prior to 30 days after
+Your receipt of the notice.
+
+5.2. If You initiate litigation against any entity by asserting a patent
+infringement claim (excluding declaratory judgment actions,
+counter-claims, and cross-claims) alleging that a Contributor Version
+directly or indirectly infringes any patent, then the rights granted to
+You by any and all Contributors for the Covered Software under Section
+2.1 of this License shall terminate.
+
+5.3. In the event of termination under Sections 5.1 or 5.2 above, all
+end user license agreements (excluding distributors and resellers) which
+have been validly granted by You or Your distributors under this License
+prior to termination shall survive termination.
+
+************************************************************************
+* *
+* 6. Disclaimer of Warranty *
+* ------------------------- *
+* *
+* Covered Software is provided under this License on an "as is" *
+* basis, without warranty of any kind, either expressed, implied, or *
+* statutory, including, without limitation, warranties that the *
+* Covered Software is free of defects, merchantable, fit for a *
+* particular purpose or non-infringing. The entire risk as to the *
+* quality and performance of the Covered Software is with You. *
+* Should any Covered Software prove defective in any respect, You *
+* (not any Contributor) assume the cost of any necessary servicing, *
+* repair, or correction. This disclaimer of warranty constitutes an *
+* essential part of this License. No use of any Covered Software is *
+* authorized under this License except under this disclaimer. *
+* *
+************************************************************************
+
+************************************************************************
+* *
+* 7. Limitation of Liability *
+* -------------------------- *
+* *
+* Under no circumstances and under no legal theory, whether tort *
+* (including negligence), contract, or otherwise, shall any *
+* Contributor, or anyone who distributes Covered Software as *
+* permitted above, be liable to You for any direct, indirect, *
+* special, incidental, or consequential damages of any character *
+* including, without limitation, damages for lost profits, loss of *
+* goodwill, work stoppage, computer failure or malfunction, or any *
+* and all other commercial damages or losses, even if such party *
+* shall have been informed of the possibility of such damages. This *
+* limitation of liability shall not apply to liability for death or *
+* personal injury resulting from such party's negligence to the *
+* extent applicable law prohibits such limitation. Some *
+* jurisdictions do not allow the exclusion or limitation of *
+* incidental or consequential damages, so this exclusion and *
+* limitation may not apply to You. *
+* *
+************************************************************************
+
+8. Litigation
+-------------
+
+Any litigation relating to this License may be brought only in the
+courts of a jurisdiction where the defendant maintains its principal
+place of business and such litigation shall be governed by laws of that
+jurisdiction, without reference to its conflict-of-law provisions.
+Nothing in this Section shall prevent a party's ability to bring
+cross-claims or counter-claims.
+
+9. Miscellaneous
+----------------
+
+This License represents the complete agreement concerning the subject
+matter hereof. If any provision of this License is held to be
+unenforceable, such provision shall be reformed only to the extent
+necessary to make it enforceable. Any law or regulation which provides
+that the language of a contract shall be construed against the drafter
+shall not be used to construe this License against a Contributor.
+
+10. Versions of the License
+---------------------------
+
+10.1. New Versions
+
+Mozilla Foundation is the license steward. Except as provided in Section
+10.3, no one other than the license steward has the right to modify or
+publish new versions of this License. Each version will be given a
+distinguishing version number.
+
+10.2. Effect of New Versions
+
+You may distribute the Covered Software under the terms of the version
+of the License under which You originally received the Covered Software,
+or under the terms of any subsequent version published by the license
+steward.
+
+10.3. Modified Versions
+
+If you create software not governed by this License, and you want to
+create a new license for such software, you may create and use a
+modified version of this License if you rename the license and remove
+any references to the name of the license steward (except to note that
+such modified license differs from this License).
+
+10.4. Distributing Source Code Form that is Incompatible With Secondary
+Licenses
+
+If You choose to distribute Source Code Form that is Incompatible With
+Secondary Licenses under the terms of this version of the License, the
+notice described in Exhibit B of this License must be attached.
+
+Exhibit A - Source Code Form License Notice
+-------------------------------------------
+
+ This Source Code Form is subject to the terms of the Mozilla Public
+ License, v. 2.0. If a copy of the MPL was not distributed with this
+ file, You can obtain one at https://mozilla.org/MPL/2.0/.
+
+If it is not possible or desirable to put the notice in a particular
+file, then You may include the notice in a location (such as a LICENSE
+file in a relevant directory) where a recipient would be likely to look
+for such a notice.
+
+You may add additional accurate notices of copyright ownership.
+
+Exhibit B - "Incompatible With Secondary Licenses" Notice
+---------------------------------------------------------
+
+ This Source Code Form is "Incompatible With Secondary Licenses", as
+ defined by the Mozilla Public License, v. 2.0.
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..1ccb5e5
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,16 @@
+.PHONY: format
+format:
+ fourmolu -i app/
+ fourmolu -i src/
+
+.PHONY: lint
+lint:
+ find {app,src}/ | entr -c hlint src/ app/
+
+.PHONY: run
+run:
+ find {app,src}/ | entr -cr cabal new-run
+
+.PHONY: repl
+repl:
+ ghcid --allow-eval --lint --command "cabal repl"
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..68db103
--- /dev/null
+++ b/README.md
@@ -0,0 +1,22 @@
+# webmaild
+
+A small SMTP server with a web interface to visualize received emails.
+
+ webmaild -smtp-port 5678 -http-port 8765
+
+will start an SMTP and HTTP server locally, ready to accept emails. Go to http://localhost:8765 to view the emails received.
+
+No authentication is required, but it will happily accept any authentication method and ignore it.
+
+The default ports, if none are provided, are `5879` for SMTP and `9785` for HTTP.
+
+Note that this is based on very loose interpretations of the respective RFCs for SMTP, HTTP and emails, and is only intended to help with debugging. I tested with like, 2 emails, and it worked well enough (:
+
+## Building & Running
+
+The recommended solution is to use `nix`:
+
+- Use `nix profile install http://git.k.mulga.net/julien/webmaild/snapshot/webmaild-main.tar.gz` to install webmaild,
+- Use `nix run http://git.k.mulga.net/julien/webmaild/snapshot/webmaild-main.tar.gz` to build and run the binary directly.
+
+If you have `cabal` installed, use `cabal build` or `cabal install`.
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
index 0000000..e82d838
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,44 @@
+module Main (main) where
+
+import qualified Cache
+import Control.Concurrent (forkIO)
+import qualified Http
+import Intro
+import qualified Queue as Q
+import qualified Smtp
+import System.Environment (getArgs)
+
+data Opts = Opts {httpPort :: String, smtpPort :: String} deriving (Show)
+
+defaultHttpPort :: String
+defaultHttpPort = "9785"
+
+defaultSmtpPort :: String
+defaultSmtpPort = "5879"
+
+main :: IO ()
+main = do
+ args <- getArgs
+ case (parseArgs args) of
+ Right opts -> do
+ putStrLn $ "Starting HTTP server at http://localhost:" ++ opts.httpPort
+ putStrLn $ "Starting SMTP server at smtp://localhost:" ++ opts.smtpPort
+
+ queue <- Q.newQueue
+ cache <- Cache.newInMemory
+ _ <- forkIO $ Cache.start queue cache
+ _ <- forkIO $ Http.runServer Nothing opts.httpPort cache queue
+ Smtp.runServer Nothing opts.smtpPort queue
+ Left err -> putStrLn ("Error. " ++ err)
+
+parseArgs :: [String] -> Either String Opts
+parseArgs args = parse args (Opts defaultHttpPort defaultSmtpPort)
+ where
+ parse [] opts = Right opts
+ parse (x1 : x2 : xs) opts
+ | x1 == "-http-port" = parse xs (opts{httpPort = x2})
+ | x1 == "-smtp-port" = parse xs (opts{smtpPort = x2})
+ parse (x : []) _
+ | x == "-http-port" = Left "Missing HTTP port"
+ | x == "-smtp-port" = Left "Missing SMTP port"
+ parse (x : _) _ = Left ("Unrecognized option: " ++ x)
diff --git a/flake.lock b/flake.lock
new file mode 100644
index 0000000..23f370c
--- /dev/null
+++ b/flake.lock
@@ -0,0 +1,80 @@
+{
+ "nodes": {
+ "flake-parts": {
+ "inputs": {
+ "nixpkgs-lib": "nixpkgs-lib"
+ },
+ "locked": {
+ "lastModified": 1709336216,
+ "narHash": "sha256-Dt/wOWeW6Sqm11Yh+2+t0dfEWxoMxGBvv3JpIocFl9E=",
+ "owner": "hercules-ci",
+ "repo": "flake-parts",
+ "rev": "f7b3c975cf067e56e7cda6cb098ebe3fb4d74ca2",
+ "type": "github"
+ },
+ "original": {
+ "owner": "hercules-ci",
+ "repo": "flake-parts",
+ "type": "github"
+ }
+ },
+ "haskell-flake": {
+ "locked": {
+ "lastModified": 1710675764,
+ "narHash": "sha256-ZpBoh1dVLTxC3wccOnsji7u/Ceuwh2raQn/Vq6BBYwo=",
+ "owner": "srid",
+ "repo": "haskell-flake",
+ "rev": "ef955d7d239d7f82f343b569a4cf2c7c1a4df1f4",
+ "type": "github"
+ },
+ "original": {
+ "owner": "srid",
+ "repo": "haskell-flake",
+ "type": "github"
+ }
+ },
+ "nixpkgs": {
+ "locked": {
+ "lastModified": 1710889954,
+ "narHash": "sha256-Pr6F5Pmd7JnNEMHHmspZ0qVqIBVxyZ13ik1pJtm2QXk=",
+ "owner": "nixos",
+ "repo": "nixpkgs",
+ "rev": "7872526e9c5332274ea5932a0c3270d6e4724f3b",
+ "type": "github"
+ },
+ "original": {
+ "owner": "nixos",
+ "ref": "nixpkgs-unstable",
+ "repo": "nixpkgs",
+ "type": "github"
+ }
+ },
+ "nixpkgs-lib": {
+ "locked": {
+ "dir": "lib",
+ "lastModified": 1709237383,
+ "narHash": "sha256-cy6ArO4k5qTx+l5o+0mL9f5fa86tYUX3ozE1S+Txlds=",
+ "owner": "NixOS",
+ "repo": "nixpkgs",
+ "rev": "1536926ef5621b09bba54035ae2bb6d806d72ac8",
+ "type": "github"
+ },
+ "original": {
+ "dir": "lib",
+ "owner": "NixOS",
+ "ref": "nixos-unstable",
+ "repo": "nixpkgs",
+ "type": "github"
+ }
+ },
+ "root": {
+ "inputs": {
+ "flake-parts": "flake-parts",
+ "haskell-flake": "haskell-flake",
+ "nixpkgs": "nixpkgs"
+ }
+ }
+ },
+ "root": "root",
+ "version": 7
+}
diff --git a/flake.nix b/flake.nix
new file mode 100644
index 0000000..ac71e74
--- /dev/null
+++ b/flake.nix
@@ -0,0 +1,25 @@
+{
+ inputs = {
+ nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";
+ flake-parts.url = "github:hercules-ci/flake-parts";
+ haskell-flake.url = "github:srid/haskell-flake";
+ };
+ outputs = inputs@{ self, nixpkgs, flake-parts, ... }:
+ flake-parts.lib.mkFlake { inherit inputs; } {
+ systems = nixpkgs.lib.systems.flakeExposed;
+ imports = [ inputs.haskell-flake.flakeModule ];
+
+ perSystem = { self', pkgs, ... }: {
+
+ haskellProjects.default = {
+ devShell = {
+ enable = true;
+ tools = hp: { fourmolu = hp.fourmolu; ghcid = hp.ghcid; };
+ hlsCheck.enable = true;
+ };
+ };
+
+ packages.default = self'.packages.webmaild;
+ };
+ };
+}
diff --git a/fourmolu.yaml b/fourmolu.yaml
new file mode 100644
index 0000000..ce46be3
--- /dev/null
+++ b/fourmolu.yaml
@@ -0,0 +1,5 @@
+column-limit: 100
+comma-style: leading
+import-export-style: leading
+indentation: 2
+respectful: false
diff --git a/src/Cache.hs b/src/Cache.hs
new file mode 100644
index 0000000..b009770
--- /dev/null
+++ b/src/Cache.hs
@@ -0,0 +1,46 @@
+module Cache (newInMemory, start, CacheM, getInbox) where
+
+import Control.Concurrent.STM
+ ( TVar
+ , atomically
+ , newTVarIO
+ , readTVar
+ , readTVarIO
+ , writeTVar
+ )
+import Intro
+import qualified Mail as M
+import qualified Queue as Q
+
+data Cache = Cache
+ { count :: Int
+ , inbox :: [M.Mail]
+ }
+
+type CacheM = TVar Cache
+
+newInMemory :: IO CacheM
+newInMemory = newTVarIO newCache
+
+start :: Q.QueueM M.Mail -> CacheM -> IO ()
+start queue cache = go
+ where
+ go :: IO ()
+ go = do
+ mail <- Q.pull queue
+ updateCache cache (`addMail` mail)
+ go
+
+getInbox :: CacheM -> IO [M.Mail]
+getInbox c = inbox <$> readTVarIO c
+
+newCache :: Cache
+newCache = Cache 0 []
+
+addMail :: Cache -> M.Mail -> Cache
+addMail cache mail = cache{count = count cache + 1, inbox = mail : inbox cache}
+
+updateCache :: CacheM -> (Cache -> Cache) -> IO ()
+updateCache c f = atomically $ do
+ cache <- readTVar c
+ writeTVar c (f cache)
diff --git a/src/Common.hs b/src/Common.hs
new file mode 100644
index 0000000..91bf708
--- /dev/null
+++ b/src/Common.hs
@@ -0,0 +1,82 @@
+module Common
+ ( toLower
+ , trim
+ , trimWith
+ , splitOn
+ , split2
+ , replace
+ , (!!?)
+ , findVal
+ , maybeAt
+ , startsWith
+ , delete
+ )
+where
+
+import Data.Char (isSpace)
+import qualified Data.Char as C
+import Data.List (find, stripPrefix)
+import Intro
+
+trim :: String -> String
+trim = f . f
+ where
+ f = reverse . dropWhile isSpace
+
+trimWith :: (Char -> Bool) -> String -> String
+trimWith p = f . f
+ where
+ f = reverse . dropWhile p
+
+splitOn :: (a -> Bool) -> [a] -> [[a]]
+splitOn p s = case dropWhile p s of
+ [] -> []
+ s' -> w : splitOn p s''
+ where
+ (w, s'') = break p s'
+
+split2 :: (a -> Bool) -> [a] -> ([a], [a])
+split2 p s =
+ case break p s of
+ (x, _ : y) -> (x, y)
+ (x, []) -> (x, [])
+
+infix 9 !!?
+
+(!!?) :: [a] -> Int -> Maybe a
+(!!?) xs i
+ | i < 0 = Nothing
+ | otherwise = go i xs
+ where
+ go :: Int -> [a] -> Maybe a
+ go 0 (x : _) = Just x
+ go j (_ : ys) = go (j - 1) ys
+ go _ [] = Nothing
+
+maybeAt :: Int -> [a] -> Maybe a
+maybeAt = flip (!!?)
+
+toLower :: String -> String
+toLower = fmap C.toLower
+
+startsWith :: (a -> Bool) -> [a] -> Bool
+startsWith _ [] = False
+startsWith p (x : _) = p x
+
+findVal :: (a -> Bool) -> [(a, b)] -> Maybe b
+findVal p xs = snd <$> find (p . fst) xs
+
+replace :: (Eq a) => [a] -> [a] -> [a] -> [a]
+replace [] to xs = go xs
+ where
+ go [] = to
+ go (x : xs') = to ++ x : go xs'
+replace from to xs | Just xs' <- stripPrefix from xs = to ++ replace from to xs'
+replace from to (x : xs) = x : replace from to xs
+replace _ _ [] = []
+
+delete :: (a -> Bool) -> [a] -> (Maybe a, [a])
+delete p = foldr f (Nothing, [])
+ where
+ f x (Nothing, xs) | p x = (Just x, xs)
+ f x (m, xs) = (m, x : xs)
diff --git a/src/Common/Mime.hs b/src/Common/Mime.hs
new file mode 100644
index 0000000..5356312
--- /dev/null
+++ b/src/Common/Mime.hs
@@ -0,0 +1,23 @@
+module Common.Mime (getType, getSubtype, MimeType (..)) where
+
+import Common (split2, trim)
+import Intro
+
+data MimeType = Text String | Image String | Application String
+
+getType :: String -> Maybe MimeType
+getType mime = case type_ of
+ "text" -> Just (Text subtype)
+ "image" -> Just (Image subtype)
+ "application" -> Just (Application subtype)
+ _ -> Nothing
+ where
+ (type_, subtype) = split2 (== '/') $ trim mime
+
+getSubtype :: String -> String
+getSubtype = trim . snd . split2 (== '/')
+
+instance Show MimeType where
+ show (Text sub) = "text/" ++ sub
+ show (Image sub) = "image/" ++ sub
+ show (Application sub) = "application/" ++ sub
diff --git a/src/Html.hs b/src/Html.hs
new file mode 100644
index 0000000..dd60e16
--- /dev/null
+++ b/src/Html.hs
@@ -0,0 +1,88 @@
+module Html (span, html, p, hr, div_, iframe, img, main_, ul, li, table, td, th, tr, a) where
+
+import Data.List (unwords)
+import Intro
+
+type Attr = (String, String)
+
+html :: [String] -> String
+html xs =
+ concat
+ [ "<html>"
+ , "<head>"
+ , script
+ [ "function resizeIframe(x) { \
+ \ x.style.height = x.contentWindow.document.documentElement.scrollHeight + 'px'; \
+ \}"
+ ]
+ , "</head>"
+ , "<body>"
+ , style
+ [ ":root { font-size: 16px; }"
+ , "* { padding: 0; margin: 0; }"
+ , "body { display: flex; flex-direction: column; gap: 1rem; padding: 1rem; }"
+ , "hr { height: 0; border: 0; border-top: 1px solid #000; }"
+ , "table { border-collapse: collapse; width: 100%; }"
+ , "td, th { border: 1px solid #000; padding: 0.4rem; }"
+ , "iframe { width: 100%; min-height: 80vh; border: none; }"
+ , "main { display: flex; flex-direction: column; gap: 1rem; }"
+ , ".part { background-color: #eee; }"
+ , ".part-body { padding: 1rem; }"
+ ]
+ , concat xs
+ , "</body></html>"
+ ]
+
+hr :: String
+hr = "<hr>"
+
+style :: [String] -> String
+style xs = concat ["<style>", concat xs, "</style>"]
+
+script :: [String] -> String
+script xs = concat ["<script>", concat xs, "</script>"]
+
+iframe :: [Attr] -> [String] -> String
+iframe xs ys = concat ["<iframe onload='resizeIframe(this)' ", attrs xs, ">", concat ys, "</iframe>"]
+
+div_ :: [Attr] -> [String] -> String
+div_ xs ys = concat ["<div ", attrs xs, ">", concat ys, "</div>"]
+
+main_ :: [String] -> String
+main_ xs = concat ["<main>", concat xs, "</main>"]
+
+p :: [String] -> String
+p xs = concat ["<p>", concat xs, "</p>"]
+
+span :: [String] -> String
+span xs = concat ["<span>", concat xs, "</span>"]
+
+a :: [Attr] -> [String] -> String
+a xs ys = concat ["<a ", attrs xs, ">", concat ys, "</a>"]
+
+table :: [String] -> String
+table xs = concat ["<table>", concat xs, "</table>"]
+
+td :: [String] -> String
+td xs = concat ["<td>", concat xs, "</td>"]
+
+th :: [String] -> String
+th xs = concat ["<th>", concat xs, "</th>"]
+
+tr :: [String] -> String
+tr xs = concat ["<tr>", concat xs, "</tr>"]
+
+ul :: [String] -> String
+ul xs = concat ["<ul>", concat xs, "</ul>"]
+
+li :: [String] -> String
+li xs = concat ["<li>", concat xs, "</li>"]
+
+img :: [Attr] -> String
+img xs = concat ["<img ", attrs xs, ">"]
+
+attr :: Attr -> String
+attr (k, v) = concat [k, "='", v, "'"]
+
+attrs :: [Attr] -> String
+attrs xs = unwords (attr <$> xs)
diff --git a/src/Http.hs b/src/Http.hs
new file mode 100644
index 0000000..f486920
--- /dev/null
+++ b/src/Http.hs
@@ -0,0 +1,75 @@
+module Http (runServer) where
+
+import qualified Cache as C
+import Common (maybeAt, splitOn)
+import qualified Html as H
+import Intro
+import qualified Mail as M
+import Network.Socket (HostName, ServiceName, Socket, socketToHandle)
+import qualified Queue as Q
+import System.IO (Handle, IOMode (ReadWriteMode), hClose, hGetLine, hPutStrLn)
+import qualified Tcp
+import qualified Template as T
+import Text.Read (readMaybe)
+
+runServer :: Maybe HostName -> ServiceName -> C.CacheM -> Q.QueueM M.Mail -> IO ()
+runServer host port cache queue = Tcp.runServer host port (sockHandler cache queue)
+
+sockHandler :: C.CacheM -> Q.QueueM M.Mail -> Socket -> IO ()
+sockHandler cache queue s = do
+ handle <- socketToHandle s ReadWriteMode
+ requestHandler handle cache queue
+
+requestHandler :: Handle -> C.CacheM -> Q.QueueM M.Mail -> IO ()
+requestHandler h cache queue = do
+ line <- hGetLine h
+ case route line of
+ ("GET", []) -> showInbox h cache
+ ("GET", ["poll", s]) -> showPolled h queue s
+ ("GET", ["mail", n]) -> case (readMaybe n :: Maybe Int) of
+ Just n' -> showMail h cache n'
+ Nothing -> showNotFound h
+ _ -> showNotFound h
+ hClose h
+
+showNotFound :: Handle -> IO ()
+showNotFound h = do
+ replyHtml h 404 [H.p ["Page not found"]]
+
+showInbox :: Handle -> C.CacheM -> IO ()
+showInbox h cache = do
+ inbox <- C.getInbox cache
+ replyHtml h 200 (T.inbox inbox)
+
+showMail :: Handle -> C.CacheM -> Int -> IO ()
+showMail h cache idx = do
+ mail <- maybeAt idx <$> C.getInbox cache
+ case mail of
+ Just mail' -> replyHtml h 200 (T.mail mail')
+ Nothing -> showNotFound h
+
+showPolled :: Handle -> Q.QueueM M.Mail -> String -> IO ()
+showPolled h queue s = do
+ mail <- Q.pullWith (\m -> m.to == [s]) queue
+ replyHtml h 200 (T.mail mail)
+
+route :: String -> (String, [String])
+route x = case words x of
+ [m, p, "HTTP/1.1"] -> (m, splitOn (== '/') p)
+ _ -> ("GET", [])
+
+replyHtml :: Handle -> Int -> [String] -> IO ()
+replyHtml h s body = do
+ let page = H.html body
+ hPutStrLn h $ "HTTP/1.1 " ++ status s
+ hPutStrLn h "content-type: text/html"
+ hPutStrLn h $ "content-length: " ++ show (length page)
+ hPutStrLn h ""
+ hPutStrLn h page
+ hPutStrLn h ""
+
+status :: Int -> String
+status s = case s of
+ 200 -> "200 OK"
+ 404 -> "404 NOT FOUND"
+ _ -> "500 INTERNAL SERVER ERROR"
diff --git a/src/Intro.hs b/src/Intro.hs
new file mode 100644
index 0000000..46e35d4
--- /dev/null
+++ b/src/Intro.hs
@@ -0,0 +1,50 @@
+module Intro
+ ( ($)
+ , (&&)
+ , (+)
+ , (++)
+ , (-)
+ , (.)
+ , (/=)
+ , (<$>)
+ , (<)
+ , (=<<)
+ , (==)
+ , (>>=)
+ , (||)
+ , Bool (False, True)
+ , Char
+ , Eq
+ , IO
+ , Int
+ , Maybe (Just, Nothing)
+ , Either (Left, Right)
+ , Show
+ , String
+ , break
+ , concat
+ , const
+ , curry
+ , dropWhile
+ , filter
+ , flip
+ , foldr
+ , fst
+ , head
+ , length
+ , fmap
+ , mconcat
+ , not
+ , otherwise
+ , pure
+ , putStrLn
+ , reverse
+ , show
+ , snd
+ , words
+ , zip
+ , zipWith
+ )
+where
+
+import Prelude
diff --git a/src/Mail.hs b/src/Mail.hs
new file mode 100644
index 0000000..830f4da
--- /dev/null
+++ b/src/Mail.hs
@@ -0,0 +1,39 @@
+module Mail
+ ( Mail (..)
+ , subject
+ , Header
+ , P.Part (..)
+ , MailM
+ , newMail
+ , setData
+ )
+where
+
+import Common (toLower)
+import Control.Monad.State.Lazy (StateT)
+import Data.List (find)
+import Intro
+import Mail.Header (Header)
+import qualified Mail.Parser as P
+
+data Mail = Mail
+ { client :: String
+ , from :: String
+ , to :: [String]
+ , headers :: [Header]
+ , body :: [P.Part]
+ }
+ deriving (Show, Eq)
+
+type MailM a = StateT Mail IO a
+
+newMail :: Mail
+newMail = Mail "" "" [] [] []
+
+setData :: [String] -> Mail -> Mail
+setData xs m = m{headers = msg.headers, body = msg.body}
+ where
+ msg = P.run xs
+
+subject :: Mail -> Maybe String
+subject m = snd <$> find (\(k, _) -> toLower k == "subject") (headers m)
diff --git a/src/Mail/Header.hs b/src/Mail/Header.hs
new file mode 100644
index 0000000..e7265b2
--- /dev/null
+++ b/src/Mail/Header.hs
@@ -0,0 +1,45 @@
+module Mail.Header
+ ( ContentType (..)
+ , Header
+ , contentType
+ , contentTransferEncoding
+ )
+where
+
+import Common (findVal, split2, splitOn, toLower, trim, trimWith)
+import Intro
+
+type Header = (String, String)
+
+data ContentType = ContentType
+ { mime :: String
+ , boundary :: Maybe String
+ , charset :: Maybe String
+ }
+ deriving (Show)
+
+newContentType :: String -> ContentType
+newContentType m = ContentType{mime = m, boundary = Nothing, charset = Nothing}
+
+contentType :: [Header] -> Maybe ContentType
+contentType xs = do
+ v <- findValIns "content-type" xs
+ case (fmap trim . splitOn (== ';')) v of
+ [y] -> pure (newContentType y)
+ y : ys ->
+ let kv = fmap (split2 (== '=')) ys
+ in pure
+ $ (newContentType y)
+ { boundary = trimQuotes <$> findValIns "boundary" kv
+ , charset = findValIns "charset" kv
+ }
+ [] -> Nothing
+
+contentTransferEncoding :: [Header] -> Maybe String
+contentTransferEncoding = findValIns "content-transfer-encoding"
+
+findValIns :: String -> [Header] -> Maybe String
+findValIns k = findVal ((== k) . toLower)
+
+trimQuotes :: String -> String
+trimQuotes = trimWith (\x -> x == '"' || x == ' ')
diff --git a/src/Mail/Parser.hs b/src/Mail/Parser.hs
new file mode 100644
index 0000000..090602c
--- /dev/null
+++ b/src/Mail/Parser.hs
@@ -0,0 +1,136 @@
+module Mail.Parser (run, Message (..), Part (..)) where
+
+import Common (startsWith, trim)
+import Control.Monad.State (State, evalState, get, gets, modify)
+import Data.Char (isSpace)
+import Data.List (intercalate)
+import Intro
+import Mail.Header (Header)
+import qualified Mail.Header as H
+
+data Message = Message
+ { headers :: [Header]
+ , body :: [Part]
+ }
+ deriving (Show)
+
+data Part = Part
+ { headers :: [Header]
+ , body :: String -- TOOD: Scoped Fields extension
+ }
+ deriving (Show, Eq)
+
+data ParserState = InHeader (Maybe Header) | InBody deriving (Show, Eq)
+
+data Parser = Parser
+ { pHeaders :: [Header]
+ , pBody :: [String]
+ , pState :: ParserState
+ , pErrors :: [String]
+ }
+ deriving (Show)
+
+type MessageM = State Parser Message
+
+type PartM = State Parser Part
+
+newParser :: Parser
+newParser = Parser [] [] (InHeader Nothing) []
+
+run :: [String] -> Message
+run xs = evalState (parseMail xs) newParser
+
+parseMail :: [String] -> MessageM
+parseMail [] = gets (evalState parseMailBody)
+parseMail (x : xs) = do
+ s <- get
+ case pState s of
+ InHeader Nothing
+ | trim x == "" -> modify (setState InBody)
+ | otherwise -> case kv x of
+ Just (k, v) -> modify (setInHeader (k, v))
+ Nothing -> modify (setInHeaderStart . pushError x)
+ InHeader (Just (k, v))
+ | trim x == "" -> modify (setState InBody . pushHeader (k, v))
+ | startsWith isSpace x -> modify (setInHeader (k, v ++ x))
+ | otherwise -> case kv x of
+ Just (k', v') -> modify (setInHeader (k', v') . pushHeader (k, v))
+ Nothing -> modify (setInHeaderStart . pushHeader (k, v) . pushError x)
+ InBody -> modify (pushBody x)
+ parseMail xs
+
+parseMailBody :: MessageM
+parseMailBody = do
+ s <- get
+ pure $ case getBoundary s of
+ Just boundary ->
+ Message
+ { headers = pHeaders s
+ , body = getPart <$> bodyParts (reverse $ pBody s) boundary
+ }
+ Nothing ->
+ Message
+ { headers = pHeaders s
+ , body = [Part{headers = [], body = intercalate "\r\n" . reverse $ pBody s}]
+ }
+ where
+ getBoundary s = H.boundary =<< (H.contentType . pHeaders) s
+ getPart part = evalState (parsePart part) newParser
+
+parsePart :: [String] -> PartM
+parsePart [] = do
+ s <- get
+ pure $ Part{headers = pHeaders s, body = intercalate "\r\n" . reverse $ pBody s}
+parsePart (x : xs) = do
+ s <- get
+ case pState s of
+ InHeader Nothing
+ | trim x == "" -> modify (setState InBody)
+ | otherwise -> case kv x of
+ Just (k, v) -> modify (setInHeader (k, v))
+ Nothing -> modify (setInHeaderStart . pushError x)
+ InHeader (Just (k, v))
+ | trim x == "" -> modify (setState InBody . pushHeader (k, v))
+ | startsWith isSpace x -> modify (setInHeader (k, v ++ x))
+ | otherwise -> case kv x of
+ Just (k', v') -> modify (setInHeader (k', v') . pushHeader (k, v))
+ Nothing -> modify (setInHeaderStart . pushHeader (k, v) . pushError x)
+ InBody -> modify (pushBody x)
+ parsePart xs
+
+pushHeader :: Header -> Parser -> Parser
+pushHeader x p = p{pHeaders = (trim <$> x) : pHeaders p}
+
+pushBody :: String -> Parser -> Parser
+pushBody x p = p{pBody = trim x : pBody p}
+
+pushError :: String -> Parser -> Parser
+pushError x p = p{pErrors = x : pErrors p}
+
+setState :: ParserState -> Parser -> Parser
+setState x p = p{pState = x}
+
+setInHeaderStart :: Parser -> Parser
+setInHeaderStart p = p{pState = InHeader Nothing}
+
+setInHeader :: Header -> Parser -> Parser
+setInHeader x p = p{pState = InHeader $ Just x}
+
+kv :: String -> Maybe (String, String)
+kv x =
+ case break (== ':') x of
+ (k, _ : v) -> Just (k, v)
+ (_, []) -> Nothing
+
+bodyParts :: [String] -> String -> [[String]]
+bodyParts lines' boundary = filter (not . isEmptyPart) $ go lines' [] []
+ where
+ go :: [String] -> [String] -> [[String]] -> [[String]]
+ go [] _ parts = parts
+ go (x : xs) acc parts
+ | trim x == ("--" ++ boundary) = go xs [] (reverse acc : parts)
+ | otherwise = go xs (x : acc) parts
+
+isEmptyPart :: [String] -> Bool
+isEmptyPart [""] = True
+isEmptyPart _ = False
diff --git a/src/Queue.hs b/src/Queue.hs
new file mode 100644
index 0000000..56af251
--- /dev/null
+++ b/src/Queue.hs
@@ -0,0 +1,65 @@
+module Queue
+ ( Queue
+ , QueueM
+ , newQueue
+ , push
+ , pull
+ , pullWith
+ )
+where
+
+import Common (delete)
+import Control.Concurrent.STM
+ ( TChan
+ , TMVar
+ , TVar
+ , atomically
+ , newEmptyTMVarIO
+ , newTChan
+ , newTVar
+ , readTChan
+ , readTVar
+ , readTVarIO
+ , takeTMVar
+ , tryPutTMVar
+ , writeTChan
+ , writeTVar
+ )
+import Control.Monad (when)
+import Intro
+
+type Selector a = (a -> Bool)
+
+data Queue a = Queue
+ { inner :: TChan a
+ , selectors :: [(Selector a, TMVar a)]
+ }
+
+type QueueM a = TVar (Queue a)
+
+newQueue :: IO (QueueM a)
+newQueue = atomically $ do
+ chan <- newTChan
+ newTVar $ Queue chan []
+
+pullWith :: Selector a -> QueueM a -> IO a
+pullWith p queueM = do
+ q <- readTVarIO queueM
+ t <- newEmptyTMVarIO
+ atomically $ writeTVar queueM (q{selectors = (p, t) : q.selectors})
+ atomically $ takeTMVar t
+
+push :: QueueM a -> a -> IO ()
+push queueM x = atomically $ do
+ q <- readTVar queueM
+ case delete (\(p, _) -> p x) q.selectors of
+ (Just (_, t), xs) -> do
+ writeTChan q.inner x
+ isPut <- tryPutTMVar t x
+ when isPut $ writeTVar queueM (q{selectors = xs})
+ (Nothing, _) -> writeTChan q.inner x
+
+pull :: QueueM a -> IO a
+pull queueM = atomically $ do
+ q <- readTVar queueM
+ readTChan q.inner
diff --git a/src/Smtp.hs b/src/Smtp.hs
new file mode 100644
index 0000000..331f6d2
--- /dev/null
+++ b/src/Smtp.hs
@@ -0,0 +1,102 @@
+module Smtp (runServer) where
+
+import Common (splitOn, trim)
+import Control.Monad (unless, when)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.State.Lazy (execStateT, modify)
+import Intro
+import qualified Mail as M
+import Network.Socket (HostName, ServiceName, Socket, socketToHandle)
+import qualified Queue as Q
+import System.IO (Handle, IOMode (ReadWriteMode), hClose, hGetLine, hPutStrLn)
+import qualified Tcp
+
+runServer :: Maybe HostName -> ServiceName -> Q.QueueM M.Mail -> IO ()
+runServer host port queue = Tcp.runServer host port (sockHandler queue)
+
+sockHandler :: Q.QueueM M.Mail -> Socket -> IO ()
+sockHandler queue s = do
+ handle <- socketToHandle s ReadWriteMode
+ hPutStrLn handle "220 service ready"
+ go handle
+ where
+ go :: Handle -> IO ()
+ go handle = do
+ mail <- execStateT (commandHandler handle) M.newMail
+ Q.push queue mail
+ go handle
+
+commandHandler :: Handle -> M.MailM ()
+commandHandler h = do
+ line <- liftIO $ hGetLine h
+ let command = words line
+ case command of
+ ["EHLO", client] -> do
+ modify (\s -> s{M.client = client})
+ replyOk h
+ commandHandler h
+ ["HELO", client] -> do
+ modify (\s -> s{M.client = client})
+ replyOk h
+ commandHandler h
+ ["AUTH", _, _] -> do
+ reply h 235 "authentication succeeded"
+ commandHandler h
+ ["MAIL", from] -> do
+ modify (\s -> s{M.from = readFrom from})
+ replyOk h
+ commandHandler h
+ ["RCPT", to] -> do
+ modify (\s -> s{M.to = readTo to : M.to s})
+ replyOk h
+ commandHandler h
+ ["DATA"] -> do
+ reply h 354 "start mail input"
+ dataHandler h
+ ["RSET"] -> do
+ modify (const M.newMail)
+ replyOk h
+ ["QUIT"] -> do
+ replyByeAndClose h
+ ["NOOP"] -> replyOk h
+ _ -> do
+ reply h 500 "unknown command"
+ liftIO $ putStrLn ("Unknown command: " ++ line)
+ pure ()
+
+dataHandler :: Handle -> M.MailM ()
+dataHandler handle = do
+ readData []
+ replyOk handle
+ replyByeAndClose handle
+ where
+ readData :: [String] -> M.MailM ()
+ readData xs = do
+ line <- liftIO $ hGetLine handle
+ let cont = trim line /= "."
+ when cont $ readData (line : xs)
+ unless cont $ modify (M.setData $ reverse xs)
+
+reply :: Handle -> Int -> String -> M.MailM ()
+reply handle status message =
+ liftIO
+ $ hPutStrLn handle
+ $ mconcat [show status, " ", message]
+
+replyOk :: Handle -> M.MailM ()
+replyOk handle = reply handle 250 "ok"
+
+replyByeAndClose :: Handle -> M.MailM ()
+replyByeAndClose handle = do
+ reply handle 221 "closing channel"
+ liftIO $ hClose handle
+
+readFrom :: String -> String
+readFrom s = filter (\c -> c /= '<' && c /= '>') $ case splitOn (== ':') s of
+ ["FROM", addr] -> addr
+ _ -> s
+
+readTo :: String -> String
+readTo s = filter (\c -> c /= '<' && c /= '>') $ case splitOn (== ':') s of
+ ["TO", addr] -> addr
+ _ -> s
diff --git a/src/Tcp.hs b/src/Tcp.hs
new file mode 100644
index 0000000..d0ee6c9
--- /dev/null
+++ b/src/Tcp.hs
@@ -0,0 +1,50 @@
+module Tcp (runServer) where
+
+import Control.Concurrent (forkFinally)
+import qualified Control.Exception as E
+import Control.Monad (forever, void)
+import Intro
+import Network.Socket
+ ( AddrInfoFlag (AI_PASSIVE)
+ , HostName
+ , ServiceName
+ , Socket
+ , SocketOption (ReuseAddr)
+ , SocketType (Stream)
+ , accept
+ , addrAddress
+ , addrFlags
+ , addrSocketType
+ , bind
+ , close
+ , defaultHints
+ , getAddrInfo
+ , gracefulClose
+ , listen
+ , openSocket
+ , setCloseOnExecIfNeeded
+ , setSocketOption
+ , withFdSocket
+ , withSocketsDo
+ )
+
+runServer :: Maybe HostName -> ServiceName -> (Socket -> IO a) -> IO a
+runServer host port server = withSocketsDo $ do
+ addr <- resolve
+ E.bracket (open addr) close go
+ where
+ resolve = do
+ let hints = defaultHints{addrFlags = [AI_PASSIVE], addrSocketType = Stream}
+ head <$> getAddrInfo (Just hints) host (Just port)
+ open addr = E.bracketOnError (openSocket addr) close $ \sock -> do
+ setSocketOption sock ReuseAddr 1
+ withFdSocket sock setCloseOnExecIfNeeded
+ bind sock $ addrAddress addr
+ listen sock 1024
+ pure sock
+ go :: Socket -> IO a
+ go sock = forever
+ $ E.bracketOnError (accept sock) (close . fst)
+ $ \(conn, _peer) ->
+ void
+ $ forkFinally (server conn) (const $ gracefulClose conn 5000)
diff --git a/src/Template.hs b/src/Template.hs
new file mode 100644
index 0000000..ff13bd3
--- /dev/null
+++ b/src/Template.hs
@@ -0,0 +1,67 @@
+module Template (inbox, mail) where
+
+import Common (replace)
+import qualified Common.Mime as Mime
+import Data.List (intercalate)
+import Data.Maybe (fromMaybe)
+import qualified Html as H
+import Intro
+import qualified Mail as M
+import qualified Mail.Header as H
+
+inbox :: [M.Mail] -> [String]
+inbox xs =
+ [ H.p [show $ length xs, " messages."]
+ , H.table $ inboxHeader : zipWith (curry inboxRow) [0 ..] xs
+ ]
+
+inboxHeader :: String
+inboxHeader = H.tr [H.th ["Subject"], H.th ["From"], H.th ["To"]]
+
+inboxRow :: (Int, M.Mail) -> String
+inboxRow (i, m) =
+ H.tr
+ [ H.td [H.a [("href", "/mail/" ++ show i)] [fromMaybe "No subject" (M.subject m)]]
+ , H.td [M.from m]
+ , H.td (M.to m)
+ ]
+
+mail :: M.Mail -> [String]
+mail m =
+ [ H.a [("href", "/")] ["Inbox"]
+ , H.p ["From: ", M.from m]
+ , H.p ["To: ", intercalate ", " $ M.to m]
+ , H.table (mailHeader <$> m.headers)
+ , H.hr
+ , H.main_ (fmap (H.div_ [("class", "part")] . mailPart) m.body)
+ ]
+
+mailHeader :: M.Header -> String
+mailHeader (k, v) = H.tr [H.td [k], H.td [v]]
+
+mailPart :: M.Part -> [String]
+mailPart p =
+ [ H.table (mailHeader <$> p.headers)
+ , H.div_ [("class", "part-body")] [mailPartBody p]
+ ]
+
+mailPartBody :: M.Part -> String
+mailPartBody p = case (mimeType, encoding) of
+ (Just (Mime.Image _), Just "base64") -> H.img [("src", concat ["data:", show mimeType, ";base64,", p.body])]
+ (_, Just "quoted-printable") -> H.iframe [("srcdoc", decodeQP p.body)] []
+ _ -> H.iframe [("srcdoc", p.body)] []
+ where
+ mimeType = (H.contentType p.headers) >>= Mime.getType . H.mime
+ encoding = H.contentTransferEncoding p.headers
+
+-- "Handles" the "quoted-printable" encoding:
+-- https://datatracker.ietf.org/doc/html/rfc1521#section-5.1
+-- This is just wrong (or, wronger than the rest), but this part of the spec
+-- is crazy, so, whatever.
+decodeQP :: String -> String
+decodeQP =
+ replace "=3D" "="
+ . replace "=C2" ""
+ . replace "=A0" " "
+ . replace "=\r" ""
+ . replace "=\r\n" ""
diff --git a/webmaild.cabal b/webmaild.cabal
new file mode 100644
index 0000000..e2ee85c
--- /dev/null
+++ b/webmaild.cabal
@@ -0,0 +1,71 @@
+cabal-version: 3.0
+name: webmaild
+version: 0.1.0.0
+license: MPL-2.0
+license-file: COPYING
+author: evuez
+maintainer: julien@mulga.net
+build-type: Simple
+
+common warnings
+ ghc-options:
+ -Wall
+ -- -Werror
+ -- -Wall-missed-specialisations
+ -Wcpp-undef
+ -Widentities
+ -Wimplicit-prelude
+ -Wincomplete-record-updates
+ -Wincomplete-uni-patterns
+ -Wmissed-specialisations
+ -- -Wmissing-deriving-strategies
+ -Wmissing-export-lists
+ -Wmissing-exported-signatures
+ -Wmissing-home-modules
+ -- -Wmissing-import-lists
+ -Wmissing-local-signatures
+ -Wmonomorphism-restriction
+ -Wpartial-fields
+ -Wredundant-constraints
+ -Wunused-packages
+ -Wunused-type-patterns
+
+common exe
+ default-extensions:
+ NoImplicitPrelude
+ DuplicateRecordFields
+ OverloadedRecordDot
+ other-modules:
+ Cache
+ Common
+ Common.Mime
+ Html
+ Http
+ Intro
+ Mail
+ Mail.Header
+ Mail.Parser
+ Queue
+ Smtp
+ Tcp
+ Template
+ build-depends: base >=4.17.2.1, network, stm, mtl
+ hs-source-dirs: app,src
+ default-language: Haskell2010
+
+executable webmaild
+ import: warnings
+ import: exe
+ main-is: Main.hs
+ ghc-options:
+ -fno-expose-internal-symbols
+ -O2
+
+executable webmaild-dyn
+ import: warnings
+ import: exe
+ main-is: Main.hs
+ ghc-options:
+ -fno-expose-internal-symbols
+ -O2
+ -dynamic
--
cgit v1.2.3