diff options
Diffstat (limited to 'Codec/Encryption')
-rw-r--r-- | Codec/Encryption/OpenPGP/ASCIIArmor.hs | 13 | ||||
-rw-r--r-- | Codec/Encryption/OpenPGP/ASCIIArmor/Decode.hs | 128 | ||||
-rw-r--r-- | Codec/Encryption/OpenPGP/ASCIIArmor/Encode.hs | 58 |
3 files changed, 199 insertions, 0 deletions
diff --git a/Codec/Encryption/OpenPGP/ASCIIArmor.hs b/Codec/Encryption/OpenPGP/ASCIIArmor.hs new file mode 100644 index 0000000..62440ae --- /dev/null +++ b/Codec/Encryption/OpenPGP/ASCIIArmor.hs | |||
@@ -0,0 +1,13 @@ | |||
1 | -- ASCIIArmor.hs: OpenPGP (RFC4880) ASCII armor implementation | ||
2 | -- Copyright Ⓒ 2012 Clint Adams | ||
3 | -- This software is released under the terms of the Expat (MIT) license. | ||
4 | -- (See the LICENSE file). | ||
5 | |||
6 | module Codec.Encryption.OpenPGP.ASCIIArmor ( | ||
7 | armor | ||
8 | , decodeArmor | ||
9 | , parseArmor | ||
10 | ) where | ||
11 | |||
12 | import Codec.Encryption.OpenPGP.ASCIIArmor.Encode (armor) | ||
13 | import Codec.Encryption.OpenPGP.ASCIIArmor.Decode (decodeArmor, parseArmor) | ||
diff --git a/Codec/Encryption/OpenPGP/ASCIIArmor/Decode.hs b/Codec/Encryption/OpenPGP/ASCIIArmor/Decode.hs new file mode 100644 index 0000000..2383ff3 --- /dev/null +++ b/Codec/Encryption/OpenPGP/ASCIIArmor/Decode.hs | |||
@@ -0,0 +1,128 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | -- ASCIIArmor/Decode.hs: OpenPGP (RFC4880) ASCII armor implementation | ||
3 | -- Copyright Ⓒ 2012 Clint Adams | ||
4 | -- This software is released under the terms of the Expat (MIT) license. | ||
5 | -- (See the LICENSE file). | ||
6 | |||
7 | module Codec.Encryption.OpenPGP.ASCIIArmor.Decode ( | ||
8 | parseArmor | ||
9 | , decodeArmor | ||
10 | ) where | ||
11 | |||
12 | import Codec.Encryption.OpenPGP.Serialize (getPackets) | ||
13 | import Codec.Encryption.OpenPGP.Types | ||
14 | import Control.Applicative (many, (<|>), (<$>)) | ||
15 | import Data.Attoparsec.ByteString (Parser, many1, string, inClass, notInClass, satisfy, word8, (<?>), parse, IResult(..)) | ||
16 | import Data.Attoparsec.ByteString.Char8 (isDigit_w8) | ||
17 | import Data.Bits (shiftL) | ||
18 | import Data.ByteString (ByteString) | ||
19 | import qualified Data.ByteString as B | ||
20 | import qualified Data.ByteString.Char8 as BC8 | ||
21 | import qualified Data.ByteString.Base64 as Base64 | ||
22 | import Data.Digest.CRC24 (crc24) | ||
23 | import Data.Serialize.Get (Get, runGet, getWord8) | ||
24 | import Data.Serialize.Put (runPut, putWord32be) | ||
25 | import Data.String (IsString, fromString) | ||
26 | import Data.Word (Word32) | ||
27 | |||
28 | decodeArmor :: (Integral a, Read a, Show a, IsString e) => ByteString -> Either e (Armor a) | ||
29 | decodeArmor bs = case parse parseArmor bs of | ||
30 | Fail t c e -> Left (fromString e) | ||
31 | Partial _ -> Left (fromString "what") | ||
32 | Done _ r -> Right r | ||
33 | |||
34 | parseArmor :: (Integral a, Read a, Show a) => Parser (Armor a) | ||
35 | parseArmor = do | ||
36 | atype <- beginLine <?> "begin line" | ||
37 | headers <- armorHeaders <?> "headers" | ||
38 | blankishLine <?> "blank line" | ||
39 | payload <- base64Data <?> "base64 data" | ||
40 | endLine atype <?> "end line" | ||
41 | case runGet getPackets payload of | ||
42 | Left err -> fail err | ||
43 | Right packets -> return $ Armor atype headers packets | ||
44 | |||
45 | beginLine :: (Integral a, Read a, Show a) => Parser (ArmorType a) | ||
46 | beginLine = do | ||
47 | string "-----BEGIN PGP " | ||
48 | atype <- message <|> pubkey <|> privkey<|> parts <|> signature | ||
49 | string "-----" | ||
50 | many (satisfy (inClass " \t")) | ||
51 | lineEnding | ||
52 | return atype | ||
53 | where | ||
54 | message = string "MESSAGE" >> return ArmorMessage | ||
55 | pubkey = string "PUBLIC KEY BLOCK" >> return ArmorPublicKeyBlock | ||
56 | privkey = string "PRIVATE KEY BLOCK" >> return ArmorPrivateKeyBlock | ||
57 | signature = string "SIGNATURE" >> return ArmorSignature | ||
58 | parts = do | ||
59 | string "MESSAGE, PART " | ||
60 | firstnum <- read . BC8.unpack . B.pack <$> many1 (satisfy isDigit_w8) | ||
61 | return $ ArmorSplitMessageIndefinite firstnum | ||
62 | |||
63 | lineEnding :: Parser ByteString | ||
64 | lineEnding = string "\n" <|> string "\r\n" | ||
65 | |||
66 | armorHeaders :: Parser [ArmorHeader] | ||
67 | armorHeaders = many armorHeader | ||
68 | |||
69 | armorHeader :: Parser ArmorHeader | ||
70 | armorHeader = do | ||
71 | key <- many1 (satisfy (inClass "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) | ||
72 | string ": " | ||
73 | val <- many1 (satisfy (notInClass "\n\r")) | ||
74 | lineEnding | ||
75 | return (B.pack key, B.pack val) | ||
76 | |||
77 | blankishLine :: Parser ByteString | ||
78 | blankishLine = many (satisfy (inClass " \t")) >> lineEnding | ||
79 | |||
80 | endLine :: (Integral a, Read a, Show a) => ArmorType a -> Parser ByteString | ||
81 | endLine atype = do | ||
82 | string $ "-----END PGP " `B.append` aType atype `B.append` "-----" | ||
83 | lineEnding | ||
84 | |||
85 | aType :: (Integral a, Read a, Show a) => ArmorType a -> ByteString | ||
86 | aType (ArmorMessage) = BC8.pack "MESSAGE" | ||
87 | aType (ArmorPublicKeyBlock) = BC8.pack "PUBLIC KEY BLOCK" | ||
88 | aType (ArmorPrivateKeyBlock) = BC8.pack "PRIVATE KEY BLOCK" | ||
89 | aType (ArmorSplitMessage x y) = BC8.pack $ "MESSAGE, PART " ++ show x ++ "/" ++ show y | ||
90 | aType (ArmorSplitMessageIndefinite x) = BC8.pack $ "MESSAGE, PART " ++ show x | ||
91 | aType (ArmorSignature) = BC8.pack "SIGNATURE" | ||
92 | |||
93 | base64Data :: Parser ByteString | ||
94 | base64Data = do | ||
95 | ls <- many1 base64Line | ||
96 | cksum <- checksumLine | ||
97 | let payload = B.concat ls | ||
98 | let ourcksum = crc24 payload | ||
99 | case runGet d24 cksum of | ||
100 | Left err -> fail err | ||
101 | Right theircksum -> if theircksum == ourcksum then return payload else fail ("CRC24 mismatch: " ++ show (B.unpack cksum) ++ "/" ++ show theircksum ++ " vs. " ++ show ourcksum) | ||
102 | where | ||
103 | base64Line :: Parser ByteString | ||
104 | base64Line = do | ||
105 | b64 <- many1 (satisfy (inClass "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")) | ||
106 | pad <- many (word8 (fromIntegral . fromEnum $ '=')) | ||
107 | lineEnding | ||
108 | let line = B.pack b64 `B.append` B.pack pad | ||
109 | case Base64.decode line of | ||
110 | Left err -> fail err | ||
111 | Right bs -> return bs | ||
112 | checksumLine :: Parser ByteString | ||
113 | checksumLine = do | ||
114 | word8 (fromIntegral . fromEnum $ '=') | ||
115 | b64 <- many1 (satisfy (inClass "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")) | ||
116 | lineEnding | ||
117 | let line = B.pack b64 | ||
118 | case Base64.decode line of | ||
119 | Left err -> fail err | ||
120 | Right bs -> return bs | ||
121 | |||
122 | |||
123 | d24 :: Get Word32 | ||
124 | d24 = do | ||
125 | a <- getWord8 | ||
126 | b <- getWord8 | ||
127 | c <- getWord8 | ||
128 | return $ shiftL (fromIntegral a :: Word32) 16 + shiftL (fromIntegral b :: Word32) 8 + (fromIntegral c :: Word32) | ||
diff --git a/Codec/Encryption/OpenPGP/ASCIIArmor/Encode.hs b/Codec/Encryption/OpenPGP/ASCIIArmor/Encode.hs new file mode 100644 index 0000000..d08c3c1 --- /dev/null +++ b/Codec/Encryption/OpenPGP/ASCIIArmor/Encode.hs | |||
@@ -0,0 +1,58 @@ | |||
1 | -- ASCIIArmor/Encode.hs: OpenPGP (RFC4880) ASCII armor implementation | ||
2 | -- Copyright Ⓒ 2012 Clint Adams | ||
3 | -- This software is released under the terms of the Expat (MIT) license. | ||
4 | -- (See the LICENSE file). | ||
5 | |||
6 | module Codec.Encryption.OpenPGP.ASCIIArmor.Encode ( | ||
7 | armor | ||
8 | ) where | ||
9 | |||
10 | import Codec.Encryption.OpenPGP.Serialize (putPackets) | ||
11 | import Codec.Encryption.OpenPGP.Types | ||
12 | import Data.ByteString (ByteString) | ||
13 | import qualified Data.ByteString as B | ||
14 | import qualified Data.ByteString.Char8 as BC8 | ||
15 | import qualified Data.ByteString.Base64 as Base64 | ||
16 | import Data.Digest.CRC24 (crc24) | ||
17 | import Data.Serialize.Put (runPut, putWord32be) | ||
18 | import Data.String (IsString, fromString) | ||
19 | |||
20 | armor :: (Integral a, Show a) => Armor a -> ByteString | ||
21 | armor (Armor atype ahs ps) = beginLine atype `B.append` armorHeaders ahs `B.append` blankLine `B.append` armorData (opgpStream ps) `B.append` armorChecksum (opgpStream ps) `B.append` endLine atype | ||
22 | |||
23 | blankLine :: ByteString | ||
24 | blankLine = BC8.singleton '\n' | ||
25 | |||
26 | beginLine :: (Integral a, Show a) => ArmorType a -> ByteString | ||
27 | beginLine atype = BC8.pack "-----BEGIN PGP " `B.append` aType atype `B.append` BC8.pack "-----\n" | ||
28 | |||
29 | endLine :: (Integral a, Show a) => ArmorType a -> ByteString | ||
30 | endLine atype = BC8.pack "-----END PGP " `B.append` aType atype `B.append` BC8.pack "-----\n" | ||
31 | |||
32 | aType :: (Integral a, Show a) => ArmorType a -> ByteString | ||
33 | aType (ArmorMessage) = BC8.pack "MESSAGE" | ||
34 | aType (ArmorPublicKeyBlock) = BC8.pack "PUBLIC KEY BLOCK" | ||
35 | aType (ArmorPrivateKeyBlock) = BC8.pack "PRIVATE KEY BLOCK" | ||
36 | aType (ArmorSplitMessage x y) = BC8.pack $ "MESSAGE, PART " ++ show x ++ "/" ++ show y | ||
37 | aType (ArmorSplitMessageIndefinite x) = BC8.pack $ "MESSAGE, PART " ++ show x | ||
38 | aType (ArmorSignature) = BC8.pack "SIGNATURE" | ||
39 | |||
40 | armorHeaders :: [ArmorHeader] -> ByteString | ||
41 | armorHeaders ahs = BC8.unlines . map armorHeader $ ahs | ||
42 | where | ||
43 | armorHeader :: ArmorHeader -> ByteString | ||
44 | armorHeader (k, v) = k `B.append` BC8.pack ": " `B.append` v | ||
45 | |||
46 | opgpStream :: [Packet] -> ByteString | ||
47 | opgpStream = runPut . putPackets | ||
48 | |||
49 | armorData :: ByteString -> ByteString | ||
50 | armorData = BC8.unlines . wrap76 . Base64.encode | ||
51 | |||
52 | wrap76 :: ByteString -> [ByteString] | ||
53 | wrap76 bs | ||
54 | | B.null bs = [] | ||
55 | | otherwise = B.take 76 bs : wrap76 (B.drop 76 bs) | ||
56 | |||
57 | armorChecksum :: ByteString -> ByteString | ||
58 | armorChecksum = BC8.cons '=' . armorData . B.tail . runPut . putWord32be . crc24 | ||