diff options
author | Andrew Cady <d@jerkface.net> | 2016-01-24 13:40:54 -0500 |
---|---|---|
committer | Andrew Cady <d@jerkface.net> | 2016-01-24 13:40:54 -0500 |
commit | ddfd92cdfaf5e8e77961fbf63589a9be4109fc64 (patch) | |
tree | d918ee80e55f4a69ac7af7394bdecdc54460a95e /src/Network/ACME | |
parent | 7b91afaf4e74fd7fa43e0d7821055bcc651a9b1a (diff) |
rename module & files; remove unused deps
Diffstat (limited to 'src/Network/ACME')
-rw-r--r-- | src/Network/ACME/Encoding.hs | 188 |
1 files changed, 188 insertions, 0 deletions
diff --git a/src/Network/ACME/Encoding.hs b/src/Network/ACME/Encoding.hs new file mode 100644 index 0000000..dc2c963 --- /dev/null +++ b/src/Network/ACME/Encoding.hs | |||
@@ -0,0 +1,188 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | {-# LANGUAGE RecordWildCards #-} | ||
3 | {-# LANGUAGE ScopedTypeVariables #-} | ||
4 | |||
5 | module Network.ACME.Encoding ( | ||
6 | Keys(..), | ||
7 | readKeys, | ||
8 | thumbprint, | ||
9 | JWK(..), | ||
10 | toStrict, | ||
11 | csr, | ||
12 | challenge, | ||
13 | registration, | ||
14 | authz, | ||
15 | signPayload, | ||
16 | ) where | ||
17 | |||
18 | import Crypto.Number.Serialize (i2osp) | ||
19 | import Data.Aeson (ToJSON (..), encode, object, (.=)) | ||
20 | import Data.ByteString (ByteString) | ||
21 | import qualified Data.ByteString as B | ||
22 | import qualified Data.ByteString.Base64.URL as Base64 | ||
23 | import qualified Data.ByteString.Char8 as BC | ||
24 | import qualified Data.ByteString.Lazy as LB | ||
25 | import qualified Data.ByteString.Lazy.Char8 as LC | ||
26 | import Data.Digest.Pure.SHA (bytestringDigest, sha256) | ||
27 | import Data.Maybe | ||
28 | import Data.Text.Encoding (decodeUtf8) | ||
29 | import OpenSSL | ||
30 | import OpenSSL.EVP.Digest | ||
31 | import OpenSSL.EVP.PKey | ||
32 | import OpenSSL.EVP.Sign | ||
33 | import OpenSSL.PEM | ||
34 | import OpenSSL.RSA | ||
35 | import Text.Email.Validate | ||
36 | import qualified Data.Text as T | ||
37 | |||
38 | data Keys = Keys RSAKeyPair RSAPubKey | ||
39 | readKeys :: String -> IO (Maybe Keys) | ||
40 | readKeys privKeyData = do | ||
41 | keypair :: SomeKeyPair <- readPrivateKey privKeyData PwTTY | ||
42 | let (priv :: Maybe RSAKeyPair) = toKeyPair keypair | ||
43 | pub <- maybe (return Nothing) (fmap Just . rsaCopyPublic) priv | ||
44 | return $ Keys <$> priv <*> pub | ||
45 | |||
46 | -------------------------------------------------------------------------------- | ||
47 | -- | Sign return a payload with a nonce-protected header. | ||
48 | signPayload :: Keys -> String -> ByteString -> IO LC.ByteString | ||
49 | signPayload (Keys priv pub) nonce_ payload = withOpenSSL $ do | ||
50 | let protected = b64 (header pub nonce_) | ||
51 | Just dig <- getDigestByName "SHA256" | ||
52 | sig <- b64 <$> signBS dig priv (B.concat [protected, ".", payload]) | ||
53 | return $ encode (Request (header' pub) protected payload sig) | ||
54 | |||
55 | -------------------------------------------------------------------------------- | ||
56 | -- | Base64URL encoding of Integer with padding '=' removed. | ||
57 | b64i :: Integer -> ByteString | ||
58 | b64i = b64 . i2osp | ||
59 | |||
60 | b64 :: ByteString -> ByteString | ||
61 | b64 = B.takeWhile (/= 61) . Base64.encode | ||
62 | |||
63 | toStrict :: LB.ByteString -> ByteString | ||
64 | toStrict = B.concat . LB.toChunks | ||
65 | |||
66 | header' :: RSAKey k => k -> Header | ||
67 | header' key = Header "RS256" (JWK (rsaE key) "RSA" (rsaN key)) Nothing | ||
68 | |||
69 | header :: RSAKey k => k -> String -> ByteString | ||
70 | header key nonce = (toStrict . encode) | ||
71 | (Header "RS256" (JWK (rsaE key) "RSA" (rsaN key)) (Just nonce)) | ||
72 | |||
73 | -- | Registration payload to sign with user key. | ||
74 | registration :: EmailAddress -> String -> ByteString | ||
75 | registration emailAddr terms = (b64 . toStrict . encode) (Reg emailAddr terms) | ||
76 | |||
77 | -- | Challenge request payload to sign with user key. | ||
78 | authz :: String -> ByteString | ||
79 | authz = b64. toStrict . encode . Authz | ||
80 | |||
81 | -- | Challenge response payload to sign with user key. | ||
82 | challenge :: ByteString -> ByteString | ||
83 | challenge = b64 . toStrict . encode . Challenge . BC.unpack | ||
84 | |||
85 | -- | CSR request payload to sign with user key. | ||
86 | csr :: ByteString -> ByteString | ||
87 | csr = b64 . toStrict . encode . CSR . b64 | ||
88 | |||
89 | thumbprint :: JWK -> ByteString | ||
90 | thumbprint = b64 . toStrict . bytestringDigest . sha256 . encodeOrdered | ||
91 | |||
92 | -- | There is an `encodePretty'` in `aeson-pretty`, but do it by hand here. | ||
93 | encodeOrdered :: JWK -> LB.ByteString | ||
94 | encodeOrdered JWK{..} = LC.pack $ | ||
95 | "{\"e\":\"" ++ hE' ++ "\",\"kty\":\"" ++ hKty ++ "\",\"n\":\"" ++ hN' ++ "\"}" | ||
96 | where | ||
97 | hE' = BC.unpack (b64i hE) | ||
98 | hN' = BC.unpack (b64i hN) | ||
99 | |||
100 | |||
101 | -------------------------------------------------------------------------------- | ||
102 | data Header = Header | ||
103 | { hAlg :: String | ||
104 | , hJwk :: JWK | ||
105 | , hNonce :: Maybe String | ||
106 | } | ||
107 | deriving Show | ||
108 | |||
109 | data JWK = JWK | ||
110 | { hE :: Integer | ||
111 | , hKty :: String | ||
112 | , hN :: Integer | ||
113 | } | ||
114 | deriving Show | ||
115 | |||
116 | instance ToJSON Header where | ||
117 | toJSON Header{..} = object $ | ||
118 | [ "alg" .= hAlg | ||
119 | , "jwk" .= toJSON hJwk | ||
120 | ] ++ maybeToList (("nonce" .=) <$> hNonce) | ||
121 | |||
122 | instance ToJSON JWK where | ||
123 | toJSON JWK{..} = object | ||
124 | [ "e" .= decodeUtf8 (b64i hE) | ||
125 | , "kty" .= hKty | ||
126 | , "n" .= decodeUtf8 (b64i hN) | ||
127 | ] | ||
128 | |||
129 | data Reg = Reg | ||
130 | { rMail :: EmailAddress | ||
131 | , rAgreement :: String | ||
132 | } | ||
133 | deriving Show | ||
134 | |||
135 | instance ToJSON Reg where | ||
136 | toJSON Reg{..} = object | ||
137 | [ "resource" .= ("new-reg" :: String) | ||
138 | , "contact" .= ["mailto:" ++ (T.unpack . decodeUtf8 . toByteString $ rMail)] | ||
139 | , "agreement" .= rAgreement | ||
140 | ] | ||
141 | |||
142 | data Request = Request | ||
143 | { rHeader :: Header | ||
144 | , rProtected :: ByteString | ||
145 | , rPayload :: ByteString | ||
146 | , rSignature :: ByteString | ||
147 | } | ||
148 | deriving Show | ||
149 | |||
150 | instance ToJSON Request where | ||
151 | toJSON Request{..} = object | ||
152 | [ "header" .= toJSON rHeader | ||
153 | , "protected" .= decodeUtf8 rProtected | ||
154 | , "payload" .= decodeUtf8 rPayload | ||
155 | , "signature" .= decodeUtf8 rSignature | ||
156 | ] | ||
157 | |||
158 | data Authz = Authz | ||
159 | { aDomain :: String | ||
160 | } | ||
161 | |||
162 | instance ToJSON Authz where | ||
163 | toJSON Authz{..} = object | ||
164 | [ "resource" .= ("new-authz" :: String) | ||
165 | , "identifier" .= object | ||
166 | [ "type" .= ("dns" :: String) | ||
167 | , "value" .= aDomain | ||
168 | ] | ||
169 | ] | ||
170 | |||
171 | data Challenge = Challenge | ||
172 | { cKeyAuth :: String | ||
173 | } | ||
174 | |||
175 | instance ToJSON Challenge where | ||
176 | toJSON Challenge{..} = object | ||
177 | [ "resource" .= ("challenge" :: String) | ||
178 | , "keyAuthorization" .= cKeyAuth | ||
179 | ] | ||
180 | |||
181 | data CSR = CSR ByteString | ||
182 | deriving Show | ||
183 | |||
184 | instance ToJSON CSR where | ||
185 | toJSON (CSR s) = object | ||
186 | [ "resource" .= ("new-cert" :: String) | ||
187 | , "csr" .= decodeUtf8 s | ||
188 | ] | ||