diff options
Diffstat (limited to 'src/Network')
-rw-r--r-- | src/Network/ACME.hs | 33 |
1 files changed, 18 insertions, 15 deletions
diff --git a/src/Network/ACME.hs b/src/Network/ACME.hs index b05b823..e08d5b9 100644 --- a/src/Network/ACME.hs +++ b/src/Network/ACME.hs | |||
@@ -41,6 +41,8 @@ import OpenSSL.RSA | |||
41 | import OpenSSL.X509.Request | 41 | import OpenSSL.X509.Request |
42 | import OpenSSL.X509 (readDerX509, X509) | 42 | import OpenSSL.X509 (readDerX509, X509) |
43 | import Data.List | 43 | import Data.List |
44 | import Control.Error | ||
45 | import Control.Arrow | ||
44 | 46 | ||
45 | type HttpProvisioner = URI -> ByteString -> IO () | 47 | type HttpProvisioner = URI -> ByteString -> IO () |
46 | 48 | ||
@@ -73,23 +75,24 @@ acmeChallengeURI dom tok = URI | |||
73 | "" | 75 | "" |
74 | 76 | ||
75 | certify :: URI -> Keys -> Maybe (URI, EmailAddress) -> HttpProvisioner -> CSR -> IO (Either String X509) | 77 | certify :: URI -> Keys -> Maybe (URI, EmailAddress) -> HttpProvisioner -> CSR -> IO (Either String X509) |
76 | certify directoryUrl keys reg provision certReq = run >>= traverse readDerX509 | 78 | certify directoryUrl keys reg provision certReq = |
77 | 79 | ||
78 | where | 80 | (mapM readDerX509 =<<) $ runACME directoryUrl keys $ do |
79 | run = | 81 | |
80 | runACME directoryUrl keys $ do | 82 | forM_ reg $ uncurry register >=> statusReport |
81 | forM_ reg $ uncurry register >=> statusReport | ||
82 | 83 | ||
83 | let performChallenge domain (ChallengeRequest nextUri token thumbtoken) = do | 84 | let performChallenge domain (ChallengeRequest nextUri token thumbtoken) = do |
84 | liftIO $ provision (acmeChallengeURI domain token) thumbtoken | 85 | liftIO $ provision (acmeChallengeURI domain token) thumbtoken |
85 | notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport | 86 | notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport |
86 | 87 | ||
87 | challengeResultLinks <- forM (csrDomains certReq) $ \dom -> | 88 | challengeResultLinks <- forM (csrDomains certReq) $ \dom -> challengeRequest dom >>= |
88 | challengeRequest dom >>= statusReport >>= extractCR >>= performChallenge dom | 89 | statusReport >>= |
90 | extractCR >>= | ||
91 | performChallenge dom | ||
89 | 92 | ||
90 | pollResults challengeResultLinks >>= | 93 | runExceptT $ do |
91 | either (return . Left . ("certificate receipt was not attempted because a challenge failed: " ++)) | 94 | ExceptT $ pollResults challengeResultLinks <&> left ("certificate receipt was not attempted because a challenge failed: " ++) |
92 | (const (retrieveCert certReq >>= statusReport <&> checkCertResponse)) | 95 | ExceptT $ retrieveCert certReq >>= statusReport <&> checkCertResponse |
93 | 96 | ||
94 | pollResults :: [Response LC.ByteString] -> ACME (Either String ()) | 97 | pollResults :: [Response LC.ByteString] -> ACME (Either String ()) |
95 | pollResults [] = return $ Right () | 98 | pollResults [] = return $ Right () |
@@ -111,9 +114,9 @@ data CSR = CSR { csrDomains :: [DomainName], csrData :: ByteString } | |||
111 | newtype WritableDir = WritableDir String | 114 | newtype WritableDir = WritableDir String |
112 | ensureWritableDir :: FilePath -> String -> IO WritableDir | 115 | ensureWritableDir :: FilePath -> String -> IO WritableDir |
113 | ensureWritableDir file name = do | 116 | ensureWritableDir file name = do |
114 | (writable <$> getPermissions file) >>= flip unless (err name) | 117 | (writable <$> getPermissions file) >>= flip unless (e name) |
115 | return $ WritableDir file | 118 | return $ WritableDir file |
116 | where err n = error $ "Error: " ++ n ++ " is not writable" | 119 | where e n = error $ "Error: " ++ n ++ " is not writable" |
117 | 120 | ||
118 | (</>) :: String -> String -> String | 121 | (</>) :: String -> String -> String |
119 | a </> b = a ++ "/" ++ b | 122 | a </> b = a ++ "/" ++ b |