summaryrefslogtreecommitdiff
path: root/lib/openpgp.hs
blob: 9c8548b350a55d8553eb7a8222406453453f2910 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
import Data.Binary
import Data.Binary.Get
import Data.Bits
import Data.Word
import qualified Data.ByteString.Lazy as LZ
import qualified Data.ByteString.Lazy.UTF8 as LZ
import qualified Codec.Compression.Zlib.Raw as Zip
import qualified Codec.Compression.Zlib as Zlib
import qualified Codec.Compression.BZip as BZip2

newtype Message = Message [Packet] deriving Show

data Packet =
	CompressedDataPacket {
		algorithm::CompressionAlgorithm,
		message::Message
	} |
	LiteralDataPacket {
		format::Char,
		filename::String,
		timestamp::Word32,
		content::LZ.ByteString
	} |
	UserIDPacket String
	deriving Show

data CompressionAlgorithm = Uncompressed | ZIP | ZLIB | BZip2 deriving Show

-- A message is encoded as a list that takes the entire file
instance Binary Message where
	put (Message []) = return ()
	put (Message (x:xs)) = do
		put x
		put (Message xs)
	get = do
		done <- isEmpty
		if done then do
			return (Message [])
		else do
			next_packet <- get :: Get Packet
			(Message tail) <- get :: Get Message
			return (Message (next_packet:tail))

instance Binary Packet where
	get = do
		tag <- get :: Get Word8
		if (tag .&. 64) /= 0 then do
			len <- parse_new_length
			let l = fromIntegral len in do
				-- This forces the whole packet to be consumed
				packet <- getLazyByteString l
				return $ runGet (parse_packet (tag .&. 63)) packet
		else do
			len <- parse_old_length tag
			let l = fromIntegral len in do
				-- This forces the whole packet to be consumed
				packet <- getLazyByteString l
				return $ runGet (parse_packet ((tag `shiftR` 2) .&. 15)) packet

-- http://tools.ietf.org/html/rfc4880#section-4.2.2
parse_new_length :: Get Word32
parse_new_length = do
	len <- get :: Get Word8
	let l = fromIntegral len in
		case len of
			-- One octet length
			_ | len < 192 -> return l
			-- Two octet length
			_ | len > 191 && len < 224 -> do
				second <- get :: Get Word8
				let s = fromIntegral second in
					return $ ((l - 192) `shiftL` 8) + s + 192
			-- Five octet length
			_ | len == 255 -> get :: Get Word32
			-- TODO: Partial body lengths. 1 << (len & 0x1F)

-- http://tools.ietf.org/html/rfc4880#section-4.2.1
parse_old_length :: Word8 -> Get Word32
parse_old_length tag =
	case (tag .&. 3) of
		-- One octet length
		0 -> do
			len <- get :: Get Word8
			return (fromIntegral len)
		-- Two octet length
		1 -> do
			len <- get :: Get Word16
			return (fromIntegral len)
		-- Four octet length
		2 -> get :: Get Word32
		-- Indeterminate length
		3 -> do
			len <- remaining
			return (fromIntegral len)

parse_packet :: Word8 -> Get Packet
-- CompressedDataPacket, http://tools.ietf.org/html/rfc4880#section-5.6
parse_packet  8 = do
	algorithm <- get :: Get Word8
	message <- getRemainingLazyByteString
	case algorithm of
		0 ->
			return (CompressedDataPacket {
				algorithm = Uncompressed,
				message = runGet (get :: Get Message) message
			})
		1 ->
			return (CompressedDataPacket {
				algorithm = ZIP,
				message = runGet (get :: Get Message) (Zip.decompress message)
			})
		2 ->
			return (CompressedDataPacket {
				algorithm = ZLIB,
				message = runGet (get :: Get Message) (Zlib.decompress message)
			})
		3 ->
			return (CompressedDataPacket {
				algorithm = BZip2,
				message = runGet (get :: Get Message) (BZip2.decompress message)
			})
-- LiteralDataPacket, http://tools.ietf.org/html/rfc4880#section-5.9
parse_packet 11 = do
	format <- get
	filenameLength <- get :: Get Word8
	filename <- getLazyByteString (fromIntegral filenameLength)
	timestamp <- get
	content <- getRemainingLazyByteString
	return (LiteralDataPacket {
		format = format,
		filename = LZ.toString filename,
		timestamp = timestamp,
		content = content
	})
-- UserIDPacket, http://tools.ietf.org/html/rfc4880#section-5.11
parse_packet 13 = do
	text <- getRemainingLazyByteString
	return (UserIDPacket (LZ.toString text))
parse_packet _ = fail "Unimplemented OpenPGP packet tag"