├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── attic └── iptables.sh ├── src ├── Leader.hs ├── Leader │ └── Consul.hs └── Warp │ └── LetsEncrypt.hs ├── stack.yaml ├── test ├── LeaderSpec.hs └── Spec.hs └── warp-letsencrypt.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | *~ 21 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Michael Snoyman 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # warp-letsencrypt 2 | Integration of the Warp webserver with Let's Encrypt 3 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main (main) where 3 | 4 | import Warp.LetsEncrypt 5 | import Network.Wai 6 | import Network.Wai.Handler.Warp 7 | import Network.HTTP.Types (status200) 8 | 9 | main :: IO () 10 | main = runLetsEncrypt 11 | ConsulSettings 12 | { consulPrefix = "warp-letsencrypt-example" 13 | } 14 | LetsEncryptSettings 15 | { lesInsecureSettings = setPort 8080 defaultSettings 16 | , lesSecureSettings = setPort 8443 defaultSettings 17 | , lesEmailAddress = "michael@snoyman.com" 18 | , lesDomains = ["tlstest.snoyman.com", "tlstest.yesodweb.com"] 19 | , lesApp = dummyApp 20 | , lesBeforeSecure = return () 21 | } 22 | 23 | dummyApp :: Application 24 | dummyApp _ send = send $ responseLBS status200 [] "Hello World!" 25 | 26 | -------------------------------------------------------------------------------- /attic/iptables.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -eux 4 | 5 | sudo iptables -A PREROUTING -t nat -p tcp --dport 80 -j REDIRECT --to-port 8080 6 | sudo iptables -A PREROUTING -t nat -p tcp --dport 443 -j REDIRECT --to-port 8443 7 | -------------------------------------------------------------------------------- /src/Leader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | module Leader 6 | ( StateId 7 | , Judge 8 | , Follower 9 | , LeaderFunction 10 | , FollowerFunction 11 | , mkInMemoryJudge 12 | , mkFollower 13 | , debounceLeader 14 | , killableFollower 15 | , runFollower 16 | ) where 17 | 18 | import ClassyPrelude.Conduit 19 | import Control.Monad.Trans.Unlift (askRunBase, MonadBaseUnlift) 20 | import Control.Concurrent.Async.Lifted.Safe (Concurrently (..), withAsync) 21 | 22 | newtype StateId = StateId Word 23 | deriving Eq 24 | 25 | -- | Decides who will be the leader 26 | newtype Judge m state = Judge (Follower m state -> m ()) 27 | 28 | mkInMemoryJudge :: forall state m n. (MonadIO m, MonadIO n, MonadBaseUnlift IO n) => m (Judge n state) 29 | mkInMemoryJudge = liftIO $ do 30 | leaderBaton <- newMVar () 31 | stateVar :: TVar (Maybe (StateId, state)) <- newTVarIO Nothing 32 | stateIdVar <- newTVarIO 0 33 | return $ Judge $ \Follower {..} -> do 34 | let beLeader = withMVar leaderBaton $ const $ do 35 | mstate <- atomically $ readTVar stateVar 36 | let setState state = atomically $ do 37 | next <- readTVar stateIdVar 38 | writeTVar stateIdVar $! next + 1 39 | writeTVar stateVar $ Just (StateId next, state) 40 | runConduit 41 | $ (followerOnLeader (snd <$> mstate) >>= yield) 42 | .| awaitForever setState 43 | beFollower = followerRun $ readTVar stateVar >>= maybe retrySTM return 44 | unlift <- askRunBase 45 | liftIO $ 46 | runConcurrently $ Concurrently (unlift beLeader) 47 | *> Concurrently (unlift beFollower) 48 | 49 | type LeaderFunction m state = Maybe state -> ConduitM () state m state 50 | type FollowerFunction m state = STM (StateId, state) -> m () 51 | 52 | data Follower m state = Follower 53 | { followerOnLeader :: !(LeaderFunction m state) 54 | , followerRun :: !(FollowerFunction m state) 55 | } 56 | 57 | runFollower :: Judge m state -> Follower m state -> m () 58 | runFollower (Judge run) = run 59 | 60 | mkFollower :: LeaderFunction m state 61 | -> FollowerFunction m state 62 | -> Follower m state 63 | mkFollower = Follower 64 | 65 | debounceLeader :: (Monad m, Eq state) => LeaderFunction m state -> LeaderFunction m state 66 | debounceLeader inner mstate = 67 | (inner mstate >>= yield) .| debounce 68 | where 69 | debounce = await >>= maybe (error "impossible") (\state -> yield state *> loop state) 70 | 71 | loop state1 = await >>= maybe (return state1) 72 | (\state2 -> 73 | if state1 == state2 74 | then loop state1 75 | else yield state2 >> loop state2) 76 | 77 | killableFollower :: (MonadIO m, MonadBaseUnlift IO m) 78 | => (state -> m ()) -> FollowerFunction m state 79 | killableFollower inner getState = do 80 | unlift <- askRunBase 81 | let loop (stateid, state) = 82 | join $ withAsync (unlift (inner state)) $ const $ atomically $ do 83 | (newid, newstate) <- getState 84 | checkSTM $ stateid /= newid 85 | return $ loop (newid, newstate) 86 | liftIO $ atomically getState >>= loop 87 | -------------------------------------------------------------------------------- /src/Leader/Consul.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | module Leader.Consul 5 | ( mkConsulJudge 6 | , mkConsulOrInMemoryJudge 7 | , ConsulSettings (..) 8 | ) where 9 | 10 | import ClassyPrelude.Conduit 11 | import Leader 12 | import Network.HTTP.Simple 13 | import Control.Monad.Trans.Unlift (MonadBaseUnlift) 14 | 15 | data ConsulSettings = ConsulSettings 16 | { consulPrefix :: !Text 17 | } 18 | 19 | mkConsulJudge :: (MonadIO m, MonadIO n) 20 | => ConsulSettings 21 | -> m (Judge n state) 22 | mkConsulJudge = undefined 23 | 24 | mkConsulOrInMemoryJudge 25 | :: (MonadIO m, MonadIO n, MonadBaseUnlift IO n) 26 | => ConsulSettings 27 | -> m (Judge n state) 28 | mkConsulOrInMemoryJudge prefix = do 29 | consulRunning <- checkConsul 30 | if consulRunning then mkConsulJudge prefix else mkInMemoryJudge 31 | 32 | checkConsul :: MonadIO m => m Bool 33 | checkConsul = liftIO $ do 34 | eres <- tryAny $ httpLBS $ setRequestMethod "HEAD" "http://localhost:8500/v1/status/leader" 35 | return $ case eres of 36 | Right res -> getResponseStatusCode res == 200 37 | Left _ -> False 38 | -------------------------------------------------------------------------------- /src/Warp/LetsEncrypt.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE NoImplicitPrelude #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | 6 | module Warp.LetsEncrypt 7 | ( LetsEncryptSettings(..) 8 | , runLetsEncrypt 9 | , ConsulSettings(..) 10 | ) where 11 | 12 | import ClassyPrelude.Conduit 13 | import Leader 14 | import Leader.Consul 15 | import Network.Wai 16 | import Network.Wai.Handler.Warp (runSettings, Settings, setBeforeMainLoop) 17 | import Network.Wai.Handler.WarpTLS (runTLS, tlsSettingsChainMemory) 18 | import System.Process.Typed 19 | import System.Directory (findExecutable, doesFileExist, createDirectoryIfMissing, getTemporaryDirectory, removeDirectoryRecursive) 20 | import Network.Mime (defaultMimeLookup) 21 | import Network.HTTP.Types (status200, status404) 22 | import System.IO.Temp (createTempDirectory) 23 | import Control.Monad.Trans.Resource (allocate) 24 | import Data.Function (fix) 25 | import Control.Concurrent.Async.Lifted.Safe (Concurrently (..)) 26 | 27 | data LetsEncryptSettings = LetsEncryptSettings 28 | { lesInsecureSettings :: !Settings 29 | , lesSecureSettings :: !Settings 30 | , lesEmailAddress :: !Text 31 | , lesDomains :: ![Text] 32 | , lesApp :: !Application 33 | , lesBeforeSecure :: !(IO ()) 34 | } 35 | 36 | config, work, logs, htdocs :: FilePath 37 | config = "config" 38 | work = "work" 39 | logs = "logs" 40 | htdocs = "htdocs" 41 | 42 | data LEState 43 | = LESJustInsecure 44 | | LESChallenge (Map FilePath ByteString) (Maybe CertInfo) 45 | | LESCerts CertInfo 46 | deriving Eq 47 | 48 | data CertInfo = CertInfo ByteString ByteString ByteString 49 | deriving Eq 50 | 51 | runLetsEncrypt :: MonadIO m 52 | => ConsulSettings 53 | -> LetsEncryptSettings 54 | -> m () 55 | runLetsEncrypt consulSettings les = liftIO $ runResourceT $ do 56 | tempDir <- liftIO getTemporaryDirectory 57 | (releaseKey, rootDir) <- allocate 58 | (createTempDirectory tempDir "warp-letsencrypt") 59 | (void . tryIO . removeDirectoryRecursive) 60 | 61 | liftIO $ createDirectoryIfMissing True $ rootDir htdocs 62 | judge <- mkConsulOrInMemoryJudge consulSettings 63 | exeName <- liftIO $ findFirstExe ["letsencrypt", "certbot"] 64 | runFollower judge $ mkFollower 65 | (debounceLeader (leader les exeName rootDir)) 66 | (killableFollower (follower les)) 67 | 68 | leader :: MonadResource m 69 | => LetsEncryptSettings 70 | -> FilePath 71 | -> FilePath 72 | -> Maybe LEState 73 | -> ConduitM () LEState m LEState 74 | leader LetsEncryptSettings {..} exeName rootDir mprevState = do 75 | moldCerts <- case mprevState of 76 | Just (LESCerts certs) -> return $ Just certs 77 | Just (LESChallenge _ moldCerts) -> return moldCerts 78 | Just LESJustInsecure -> return Nothing 79 | Nothing -> yield LESJustInsecure $> Nothing 80 | liftIO lesBeforeSecure 81 | let pc = setStdin closed $ setStderr createSource $ proc exeName 82 | [ "certonly" 83 | , "--non-interactive", "--verbose" 84 | , "--email", unpack lesEmailAddress 85 | , "--agree-tos", "--webroot" 86 | , "--config-dir", rootDir config 87 | , "--work-dir", rootDir work 88 | , "--logs-dir", rootDir logs 89 | , "-w", rootDir htdocs 90 | , "-d", unpack $ intercalate "," lesDomains 91 | ] 92 | bracketP (startProcess pc) stopProcess $ \p -> do 93 | filesReady <- liftIO $ newTVarIO False 94 | let checkFilesReady = fix $ \loop -> do 95 | mbs <- await 96 | let ready = atomically $ writeTVar filesReady True 97 | case mbs of 98 | Nothing -> ready 99 | Just bs 100 | | "verification" `isInfixOf` bs -> ready 101 | | otherwise -> loop 102 | 103 | errVar <- liftIO newEmptyTMVarIO 104 | 105 | liftIO 106 | $ fork 107 | $ runConduit 108 | $ getStderr p 109 | .| getZipSink 110 | (ZipSink (linesUnboundedAsciiC .| checkFilesReady) 111 | *> ZipSink (sinkLazy >>= atomically . putTMVar errVar)) 112 | 113 | atomically $ readTVar filesReady >>= checkSTM 114 | let dir = rootDir htdocs "" 115 | files <- sourceDirectoryDeep True dir .| foldMapMC 116 | (\fp -> do 117 | suffix <- 118 | case stripPrefix dir fp of 119 | Nothing -> error $ "Bad file list: " ++ show (dir, fp) 120 | Just suffix -> return $ fromMaybe suffix $ stripPrefix "/" suffix 121 | bs <- readFile fp 122 | return $ singletonMap suffix bs) 123 | yield $ LESChallenge files moldCerts 124 | liftIO $ checkExitCode p `onException` do 125 | err <- atomically $ takeTMVar errVar 126 | runConduit $ sourceLazy err .| stderrC 127 | 128 | domain <- 129 | case lesDomains of 130 | [] -> error "No domains" 131 | x:_ -> return x 132 | let readFile' fp = readFile $ rootDir config "live" unpack domain fp 133 | 134 | forever $ do 135 | cert <- readFile' "cert.pem" 136 | chain <- readFile' "chain.pem" 137 | privkey <- readFile' "privkey.pem" 138 | yield $ LESCerts $ CertInfo cert chain privkey 139 | 140 | threadDelay $ 1000 * 1000 * 60 * 60 * 12 -- 12 hours 141 | runProcess_ $ proc exeName 142 | [ "renew" 143 | , "--non-interactive" 144 | , "--agree-tos" 145 | , "--config-dir", rootDir config 146 | , "--work-dir", rootDir work 147 | , "--logs-dir", rootDir logs 148 | ] 149 | 150 | follower :: MonadIO m => LetsEncryptSettings -> LEState -> m () 151 | follower LetsEncryptSettings {..} LESJustInsecure = 152 | liftIO $ runSettings lesInsecureSettings lesApp 153 | follower LetsEncryptSettings {..} (LESChallenge files moldCerts) = 154 | liftIO $ withSecure $ runSettings lesInsecureSettings app 155 | where 156 | withSecure insecure = 157 | case moldCerts of 158 | Nothing -> insecure 159 | Just oldCerts -> runConcurrently 160 | $ Concurrently insecure 161 | *> Concurrently (runTLS (mkTlsSettings oldCerts) lesSecureSettings $ addSecureHeader lesApp) 162 | app req send = do 163 | let path = intercalate "/" $ pathInfo req 164 | mime = defaultMimeLookup path 165 | case lookup (unpack path) files of 166 | Nothing -> lesApp req send 167 | Just bs -> send $ responseBuilder status200 [("Content-Type", mime)] (toBuilder bs) 168 | follower LetsEncryptSettings {..} (LESCerts certInfo) = 169 | liftIO $ runConcurrently $ Concurrently secure *> Concurrently insecure 170 | where 171 | secure = runTLS (mkTlsSettings certInfo) lesSecureSettings (addSecureHeader lesApp) 172 | 173 | insecure = runSettings lesInsecureSettings lesApp 174 | 175 | mkTlsSettings (CertInfo cert chain privkey) = tlsSettingsChainMemory cert [chain] privkey 176 | 177 | addSecureHeader app req send = 178 | app req' send 179 | where 180 | req' = req 181 | { requestHeaders = ("X-Forwarded-Proto", "https") : requestHeaders req } 182 | 183 | findFirstExe :: [String] -> IO FilePath 184 | findFirstExe origs = 185 | let loop [] = 186 | error $ 187 | "None of the following executables were found: " ++ intercalate ", " origs 188 | loop (x:xs) = do 189 | mres <- findExecutable x 190 | case mres of 191 | Nothing -> loop xs 192 | Just res -> return res 193 | in loop origs 194 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-8.3 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.3" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /test/LeaderSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | module LeaderSpec (spec) where 5 | 6 | import Test.Hspec 7 | import ClassyPrelude.Conduit 8 | import Leader 9 | import Leader.Consul 10 | 11 | spec :: Spec 12 | spec = do 13 | describe "In memory sanity checks" $ sanity mkInMemoryJudge 14 | describe "In memory or Consul sanity checks" $ sanity $ mkConsulOrInMemoryJudge ConsulSettings 15 | { consulPrefix = "leader-test" 16 | } 17 | 18 | sanity :: (forall a. IO (Judge IO a)) -> Spec 19 | sanity mkJudge = do 20 | it "runs the leader once" $ do 21 | leaderCount <- newTVarIO (0 :: Int) 22 | followerCount <- newTVarIO (0 :: Int) 23 | judge <- mkJudge 24 | let follower = mkFollower 25 | (\mstate -> 26 | case mstate of 27 | Nothing -> atomically $ modifyTVar leaderCount (+ 1) 28 | Just () -> forever $ threadDelay maxBound) 29 | (killableFollower $ \() -> atomically $ modifyTVar followerCount (+ 1)) 30 | run = runFollower judge follower 31 | withAsync run $ const $ withAsync run $ const $ withAsync run $ const $ do 32 | atomically $ readTVar followerCount >>= checkSTM . (== 3) 33 | atomically (readTVar leaderCount) >>= (`shouldBe` 1) 34 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /warp-letsencrypt.cabal: -------------------------------------------------------------------------------- 1 | name: warp-letsencrypt 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/snoyberg/warp-letsencrypt#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author name here 9 | maintainer: example@example.com 10 | copyright: 2017 Author name here 11 | category: Web 12 | build-type: Simple 13 | extra-source-files: README.md 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Warp.LetsEncrypt 19 | Leader 20 | Leader.Consul 21 | build-depends: base >= 4.7 && < 5 22 | , wai 23 | , warp 24 | , warp-tls 25 | , http-types 26 | , classy-prelude-conduit 27 | , typed-process 28 | , temporary 29 | , directory 30 | , wai-extra 31 | , mime-types 32 | , resourcet 33 | , monad-unlift 34 | , lifted-async 35 | , http-conduit 36 | default-language: Haskell2010 37 | 38 | executable warp-letsencrypt-example 39 | hs-source-dirs: app 40 | main-is: Main.hs 41 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 42 | build-depends: base 43 | , warp-letsencrypt 44 | , wai 45 | , http-types 46 | , warp 47 | default-language: Haskell2010 48 | 49 | test-suite warp-letsencrypt-test 50 | type: exitcode-stdio-1.0 51 | main-is: Spec.hs 52 | default-language: Haskell2010 53 | hs-source-dirs: test 54 | build-depends: base 55 | , warp-letsencrypt 56 | , classy-prelude-conduit 57 | , hspec 58 | other-modules: LeaderSpec 59 | 60 | source-repository head 61 | type: git 62 | location: https://github.com/snoyberg/warp-letsencrypt 63 | --------------------------------------------------------------------------------