diff options
Diffstat (limited to 'src/Network')
-rw-r--r-- | src/Network/ACME.hs | 181 |
1 files changed, 181 insertions, 0 deletions
diff --git a/src/Network/ACME.hs b/src/Network/ACME.hs new file mode 100644 index 0000000..116a291 --- /dev/null +++ b/src/Network/ACME.hs | |||
@@ -0,0 +1,181 @@ | |||
1 | {-# LANGUAGE FlexibleContexts #-} | ||
2 | {-# LANGUAGE OverloadedStrings #-} | ||
3 | {-# LANGUAGE ScopedTypeVariables #-} | ||
4 | |||
5 | -------------------------------------------------------------------------------- | ||
6 | -- | Get a certificate from Let's Encrypt using the ACME protocol. | ||
7 | -- | ||
8 | -- https://github.com/ietf-wg-acme/acme/blob/master/draft-ietf-acme-acme.md | ||
9 | |||
10 | module Network.ACME where | ||
11 | |||
12 | import Control.Lens hiding (each, (.=)) | ||
13 | import Control.Monad | ||
14 | import Control.Monad.RWS.Strict | ||
15 | import Data.Aeson (Value) | ||
16 | import Data.Aeson.Lens hiding (key) | ||
17 | import qualified Data.Aeson.Lens as JSON | ||
18 | import Data.ByteString (ByteString) | ||
19 | import qualified Data.ByteString.Char8 as BC | ||
20 | import qualified Data.ByteString.Lazy as LB | ||
21 | import qualified Data.ByteString.Lazy.Char8 as LC | ||
22 | import Data.Coerce | ||
23 | import Data.String (fromString) | ||
24 | import qualified Data.Text as T | ||
25 | import Data.Text.Encoding (decodeUtf8, encodeUtf8) | ||
26 | import Data.Time.Clock.POSIX (getPOSIXTime) | ||
27 | import Network.ACME.Encoding | ||
28 | import Network.Wreq (Response, checkStatus, defaults, | ||
29 | responseBody, responseHeader, | ||
30 | responseStatus, statusCode, | ||
31 | statusMessage) | ||
32 | import qualified Network.Wreq as W | ||
33 | import qualified Network.Wreq.Session as WS | ||
34 | import OpenSSL.RSA | ||
35 | import Pipes | ||
36 | import System.Directory | ||
37 | import Text.Email.Validate | ||
38 | import Text.Domain.Validate hiding (validate) | ||
39 | import Network.URI | ||
40 | |||
41 | certify :: URI -> Keys -> Maybe EmailAddress -> URI -> [DomainName] -> WritableDir -> CSR -> IO (Either String LC.ByteString) | ||
42 | certify directoryUrl keys optEmail terms requestDomains optChallengeDir csrData = | ||
43 | |||
44 | runACME directoryUrl keys $ do | ||
45 | forM_ optEmail $ register terms >=> statusReport | ||
46 | |||
47 | let producer :: Producer ChallengeRequest ACME () | ||
48 | producer = for (each requestDomains) $ challengeRequest >=> statusReport >=> extractCR >=> yield | ||
49 | consumer :: Consumer ChallengeRequest ACME () | ||
50 | consumer = forever $ await >>= consume1 | ||
51 | consume1 (ChallengeRequest nextUri token thumbtoken) = do | ||
52 | lift $ liftIO $ BC.writeFile (coerce optChallengeDir </> BC.unpack token) thumbtoken | ||
53 | notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport | ||
54 | |||
55 | runEffect $ producer >-> consumer | ||
56 | |||
57 | retrieveCert csrData >>= statusReport <&> checkCertResponse | ||
58 | |||
59 | data ChallengeRequest = ChallengeRequest { crUri :: String, crToken :: ByteString, crThumbToken :: ByteString } | ||
60 | |||
61 | newtype CSR = CSR ByteString | ||
62 | |||
63 | newtype WritableDir = WritableDir String | ||
64 | ensureWritableDir :: FilePath -> String -> IO WritableDir | ||
65 | ensureWritableDir file name = do | ||
66 | (writable <$> getPermissions file) >>= flip unless (err name) | ||
67 | return $ WritableDir file | ||
68 | where err n = error $ "Error: " ++ n ++ " is not writable" | ||
69 | |||
70 | (</>) :: String -> String -> String | ||
71 | a </> b = a ++ "/" ++ b | ||
72 | infixr 5 </> | ||
73 | |||
74 | canProvision :: WritableDir -> DomainName -> IO Bool | ||
75 | canProvision challengeDir domain = do | ||
76 | randomish <- fromString . show <$> getPOSIXTime | ||
77 | |||
78 | let absFile = coerce challengeDir </> relFile | ||
79 | relFile = ".test." ++ show randomish | ||
80 | |||
81 | LC.writeFile absFile randomish | ||
82 | r <- W.get $ "http://" ++ show domain </> ".well-known/acme-challenge" </> relFile | ||
83 | removeFile absFile | ||
84 | return $ r ^. responseBody == randomish | ||
85 | |||
86 | |||
87 | extractCR :: MonadReader Env m => Response LC.ByteString -> m ChallengeRequest | ||
88 | extractCR r = do | ||
89 | Keys _ pub <- asks getKeys | ||
90 | let httpChallenge :: (Value -> Const (Endo s) Value) -> Response LC.ByteString -> Const (Endo s) (Response LC.ByteString) | ||
91 | httpChallenge = responseBody . | ||
92 | JSON.key "challenges" . | ||
93 | to universe . | ||
94 | traverse . | ||
95 | (filtered . has $ ix "type" . only "http-01") | ||
96 | |||
97 | token = r ^?! httpChallenge . JSON.key "token" . _String . to encodeUtf8 | ||
98 | crUri = r ^?! httpChallenge . JSON.key "uri" . _String . to T.unpack | ||
99 | |||
100 | thumb = thumbprint (JWK (rsaE pub) "RSA" (rsaN pub)) | ||
101 | thumbtoken = toStrict (LB.fromChunks [token, ".", thumb]) | ||
102 | |||
103 | return $ ChallengeRequest crUri token thumbtoken | ||
104 | |||
105 | ncErrorReport :: (Show body, AsValue body, MonadIO m) => Response body -> m () | ||
106 | ncErrorReport r = | ||
107 | when (Just "pending" /= r ^? responseBody . JSON.key "status" . _String) $ liftIO $ do | ||
108 | putStrLn "Unexpected response to challenge-response request:" | ||
109 | print r | ||
110 | |||
111 | checkCertResponse :: Response LC.ByteString -> Either String LC.ByteString | ||
112 | checkCertResponse r = | ||
113 | if isSuccess $ r ^. responseStatus . statusCode | ||
114 | then Right $ r ^. responseBody | ||
115 | else | ||
116 | let (summary, details) = (k "type", k "detail") | ||
117 | k x = r ^?! responseBody . JSON.key x . _String . to T.unpack | ||
118 | in Left $ summary ++ " ---- " ++ details | ||
119 | where | ||
120 | isSuccess n = n >= 200 && n <= 300 | ||
121 | |||
122 | retrieveCert :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => CSR -> m (Response LC.ByteString) | ||
123 | retrieveCert input = sendPayload _newCert (csr $ coerce input) | ||
124 | |||
125 | notifyChallenge :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => String -> ByteString -> m (Response LC.ByteString) | ||
126 | notifyChallenge crUri thumbtoken = sendPayload (const crUri) (challenge thumbtoken) | ||
127 | |||
128 | data Env = Env { getDir :: Directory, getKeys :: Keys, getSession :: WS.Session } | ||
129 | |||
130 | type ACME = RWST Env () Nonce IO | ||
131 | runACME :: URI -> Keys -> ACME a -> IO a | ||
132 | runACME url keys f = WS.withSession $ \sess -> do | ||
133 | Just (dir, nonce) <- getDirectory sess (show url) | ||
134 | fst <$> evalRWST f (Env dir keys sess) nonce | ||
135 | |||
136 | data Directory = Directory { | ||
137 | _newCert :: String, | ||
138 | _newAuthz :: String, | ||
139 | _revokeCert :: String, | ||
140 | _newReg :: String | ||
141 | } | ||
142 | newtype Nonce = Nonce String | ||
143 | |||
144 | getDirectory :: WS.Session -> String -> IO (Maybe (Directory, Nonce)) | ||
145 | getDirectory sess url = do | ||
146 | r <- WS.get sess url | ||
147 | let nonce = r ^? responseHeader "Replay-Nonce" . to (Nonce . T.unpack . decodeUtf8) | ||
148 | k x = r ^? responseBody . JSON.key x . _String . to T.unpack | ||
149 | return $ (,) <$> (Directory <$> k "new-cert" <*> k "new-authz" <*> k "revoke-cert" <*> k "new-reg") <*> nonce | ||
150 | |||
151 | register :: URI -> EmailAddress -> ACME (Response LC.ByteString) | ||
152 | register terms email = sendPayload _newReg (registration email (show terms)) | ||
153 | |||
154 | challengeRequest :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => DomainName -> m (Response LC.ByteString) | ||
155 | challengeRequest = sendPayload _newAuthz . authz . show | ||
156 | |||
157 | statusLine :: Response body -> String | ||
158 | statusLine r = (r ^. responseStatus . statusCode . to show) ++ " " ++ r ^. responseStatus . statusMessage . to (T.unpack . decodeUtf8) | ||
159 | |||
160 | statusReport :: MonadIO m => Response body -> m (Response body) | ||
161 | statusReport r = do | ||
162 | liftIO $ putStrLn $ statusLine r | ||
163 | return r | ||
164 | |||
165 | sendPayload :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => (Directory -> String) -> ByteString -> m (Response LC.ByteString) | ||
166 | sendPayload reqType payload = do | ||
167 | keys <- asks getKeys | ||
168 | dir <- asks getDir | ||
169 | nonce <- gets coerce | ||
170 | signed <- liftIO $ signPayload keys nonce payload | ||
171 | post (reqType dir) signed | ||
172 | |||
173 | post :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => String -> LC.ByteString -> m (Response LC.ByteString) | ||
174 | post url payload = do | ||
175 | sess <- asks getSession | ||
176 | r <- liftIO $ WS.postWith noStatusCheck sess url payload | ||
177 | put $ r ^?! responseHeader "Replay-Nonce" . to (Nonce . T.unpack . decodeUtf8) | ||
178 | return r | ||
179 | where | ||
180 | noStatusCheck = defaults & checkStatus .~ Just nullChecker | ||
181 | nullChecker _ _ _ = Nothing | ||