From e4a8fe59707fc33ef26e1ca1dec4299a0d7ba6bf Mon Sep 17 00:00:00 2001 From: Clint Adams Date: Sun, 1 Apr 2012 22:19:21 -0400 Subject: ASCII armor support --- Codec/Encryption/OpenPGP/ASCIIArmor.hs | 13 +++ Codec/Encryption/OpenPGP/ASCIIArmor/Decode.hs | 128 ++++++++++++++++++++++++++ Codec/Encryption/OpenPGP/ASCIIArmor/Encode.hs | 58 ++++++++++++ 3 files changed, 199 insertions(+) create mode 100644 Codec/Encryption/OpenPGP/ASCIIArmor.hs create mode 100644 Codec/Encryption/OpenPGP/ASCIIArmor/Decode.hs create mode 100644 Codec/Encryption/OpenPGP/ASCIIArmor/Encode.hs 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 @@ +-- ASCIIArmor.hs: OpenPGP (RFC4880) ASCII armor implementation +-- Copyright Ⓒ 2012 Clint Adams +-- This software is released under the terms of the Expat (MIT) license. +-- (See the LICENSE file). + +module Codec.Encryption.OpenPGP.ASCIIArmor ( + armor + , decodeArmor + , parseArmor +) where + +import Codec.Encryption.OpenPGP.ASCIIArmor.Encode (armor) +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 @@ +{-# LANGUAGE OverloadedStrings #-} +-- ASCIIArmor/Decode.hs: OpenPGP (RFC4880) ASCII armor implementation +-- Copyright Ⓒ 2012 Clint Adams +-- This software is released under the terms of the Expat (MIT) license. +-- (See the LICENSE file). + +module Codec.Encryption.OpenPGP.ASCIIArmor.Decode ( + parseArmor + , decodeArmor +) where + +import Codec.Encryption.OpenPGP.Serialize (getPackets) +import Codec.Encryption.OpenPGP.Types +import Control.Applicative (many, (<|>), (<$>)) +import Data.Attoparsec.ByteString (Parser, many1, string, inClass, notInClass, satisfy, word8, (), parse, IResult(..)) +import Data.Attoparsec.ByteString.Char8 (isDigit_w8) +import Data.Bits (shiftL) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC8 +import qualified Data.ByteString.Base64 as Base64 +import Data.Digest.CRC24 (crc24) +import Data.Serialize.Get (Get, runGet, getWord8) +import Data.Serialize.Put (runPut, putWord32be) +import Data.String (IsString, fromString) +import Data.Word (Word32) + +decodeArmor :: (Integral a, Read a, Show a, IsString e) => ByteString -> Either e (Armor a) +decodeArmor bs = case parse parseArmor bs of + Fail t c e -> Left (fromString e) + Partial _ -> Left (fromString "what") + Done _ r -> Right r + +parseArmor :: (Integral a, Read a, Show a) => Parser (Armor a) +parseArmor = do + atype <- beginLine "begin line" + headers <- armorHeaders "headers" + blankishLine "blank line" + payload <- base64Data "base64 data" + endLine atype "end line" + case runGet getPackets payload of + Left err -> fail err + Right packets -> return $ Armor atype headers packets + +beginLine :: (Integral a, Read a, Show a) => Parser (ArmorType a) +beginLine = do + string "-----BEGIN PGP " + atype <- message <|> pubkey <|> privkey<|> parts <|> signature + string "-----" + many (satisfy (inClass " \t")) + lineEnding + return atype + where + message = string "MESSAGE" >> return ArmorMessage + pubkey = string "PUBLIC KEY BLOCK" >> return ArmorPublicKeyBlock + privkey = string "PRIVATE KEY BLOCK" >> return ArmorPrivateKeyBlock + signature = string "SIGNATURE" >> return ArmorSignature + parts = do + string "MESSAGE, PART " + firstnum <- read . BC8.unpack . B.pack <$> many1 (satisfy isDigit_w8) + return $ ArmorSplitMessageIndefinite firstnum + +lineEnding :: Parser ByteString +lineEnding = string "\n" <|> string "\r\n" + +armorHeaders :: Parser [ArmorHeader] +armorHeaders = many armorHeader + +armorHeader :: Parser ArmorHeader +armorHeader = do + key <- many1 (satisfy (inClass "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) + string ": " + val <- many1 (satisfy (notInClass "\n\r")) + lineEnding + return (B.pack key, B.pack val) + +blankishLine :: Parser ByteString +blankishLine = many (satisfy (inClass " \t")) >> lineEnding + +endLine :: (Integral a, Read a, Show a) => ArmorType a -> Parser ByteString +endLine atype = do + string $ "-----END PGP " `B.append` aType atype `B.append` "-----" + lineEnding + +aType :: (Integral a, Read a, Show a) => ArmorType a -> ByteString +aType (ArmorMessage) = BC8.pack "MESSAGE" +aType (ArmorPublicKeyBlock) = BC8.pack "PUBLIC KEY BLOCK" +aType (ArmorPrivateKeyBlock) = BC8.pack "PRIVATE KEY BLOCK" +aType (ArmorSplitMessage x y) = BC8.pack $ "MESSAGE, PART " ++ show x ++ "/" ++ show y +aType (ArmorSplitMessageIndefinite x) = BC8.pack $ "MESSAGE, PART " ++ show x +aType (ArmorSignature) = BC8.pack "SIGNATURE" + +base64Data :: Parser ByteString +base64Data = do + ls <- many1 base64Line + cksum <- checksumLine + let payload = B.concat ls + let ourcksum = crc24 payload + case runGet d24 cksum of + Left err -> fail err + Right theircksum -> if theircksum == ourcksum then return payload else fail ("CRC24 mismatch: " ++ show (B.unpack cksum) ++ "/" ++ show theircksum ++ " vs. " ++ show ourcksum) + where + base64Line :: Parser ByteString + base64Line = do + b64 <- many1 (satisfy (inClass "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")) + pad <- many (word8 (fromIntegral . fromEnum $ '=')) + lineEnding + let line = B.pack b64 `B.append` B.pack pad + case Base64.decode line of + Left err -> fail err + Right bs -> return bs + checksumLine :: Parser ByteString + checksumLine = do + word8 (fromIntegral . fromEnum $ '=') + b64 <- many1 (satisfy (inClass "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")) + lineEnding + let line = B.pack b64 + case Base64.decode line of + Left err -> fail err + Right bs -> return bs + + +d24 :: Get Word32 +d24 = do + a <- getWord8 + b <- getWord8 + c <- getWord8 + 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 @@ +-- ASCIIArmor/Encode.hs: OpenPGP (RFC4880) ASCII armor implementation +-- Copyright Ⓒ 2012 Clint Adams +-- This software is released under the terms of the Expat (MIT) license. +-- (See the LICENSE file). + +module Codec.Encryption.OpenPGP.ASCIIArmor.Encode ( + armor +) where + +import Codec.Encryption.OpenPGP.Serialize (putPackets) +import Codec.Encryption.OpenPGP.Types +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC8 +import qualified Data.ByteString.Base64 as Base64 +import Data.Digest.CRC24 (crc24) +import Data.Serialize.Put (runPut, putWord32be) +import Data.String (IsString, fromString) + +armor :: (Integral a, Show a) => Armor a -> ByteString +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 + +blankLine :: ByteString +blankLine = BC8.singleton '\n' + +beginLine :: (Integral a, Show a) => ArmorType a -> ByteString +beginLine atype = BC8.pack "-----BEGIN PGP " `B.append` aType atype `B.append` BC8.pack "-----\n" + +endLine :: (Integral a, Show a) => ArmorType a -> ByteString +endLine atype = BC8.pack "-----END PGP " `B.append` aType atype `B.append` BC8.pack "-----\n" + +aType :: (Integral a, Show a) => ArmorType a -> ByteString +aType (ArmorMessage) = BC8.pack "MESSAGE" +aType (ArmorPublicKeyBlock) = BC8.pack "PUBLIC KEY BLOCK" +aType (ArmorPrivateKeyBlock) = BC8.pack "PRIVATE KEY BLOCK" +aType (ArmorSplitMessage x y) = BC8.pack $ "MESSAGE, PART " ++ show x ++ "/" ++ show y +aType (ArmorSplitMessageIndefinite x) = BC8.pack $ "MESSAGE, PART " ++ show x +aType (ArmorSignature) = BC8.pack "SIGNATURE" + +armorHeaders :: [ArmorHeader] -> ByteString +armorHeaders ahs = BC8.unlines . map armorHeader $ ahs + where + armorHeader :: ArmorHeader -> ByteString + armorHeader (k, v) = k `B.append` BC8.pack ": " `B.append` v + +opgpStream :: [Packet] -> ByteString +opgpStream = runPut . putPackets + +armorData :: ByteString -> ByteString +armorData = BC8.unlines . wrap76 . Base64.encode + +wrap76 :: ByteString -> [ByteString] +wrap76 bs + | B.null bs = [] + | otherwise = B.take 76 bs : wrap76 (B.drop 76 bs) + +armorChecksum :: ByteString -> ByteString +armorChecksum = BC8.cons '=' . armorData . B.tail . runPut . putWord32be . crc24 -- cgit v1.2.3