
  0 | module Network.TLS.Parse.PEM
  1 | 
  2 | import Control.Monad.Trans
  3 | import Data.String
  4 | import Data.String.Extra
  5 | import Data.String.Parser
  6 | import Utils.Base64
  7 | import Utils.Bytes
  8 | import Utils.Misc
  9 | 
 10 | public export
 11 | record PEMBlob where
 12 |   constructor MkPEMBlob
 13 |   label : String
 14 |   content : List Bits8
 15 | 
 16 | public export
 17 | Show PEMBlob where
 18 |   show (MkPEMBlob label content) = label <+> ": " <+> xxd content
 19 | 
 20 | is_label_char : Char -> Bool
 21 | is_label_char c = (not (isControl c)) && (c /= '-')
 22 | 
 23 | label_char : Applicative m => ParseT m Char
 24 | label_char = satisfy is_label_char <?> "expected label character"
 25 | 
 26 | base64_char : Applicative m => ParseT m Char
 27 | base64_char = satisfy is_base64_char <?> "expected base64 character"
 28 | 
 29 | takeUntil : Monad m => (stop : String) -> ParseT m ()
 30 | takeUntil stop = do
 31 |     let StrCons s top = strM stop
 32 |       | StrNil => pure ()
 33 |     takeUntil' s top
 34 |   where
 35 |     takeUntil' : Monad m' => (s : Char) -> (top : String) -> ParseT m' ()
 36 |     takeUntil' s top = do
 37 |         init <- takeWhile (/= s)
 38 |         skip $ char s <?> "end of string reached - \{show stop} not found"
 39 |         case !(succeeds $ string top) of
 40 |              False => takeUntil' s top
 41 |              True => pure ()
 42 | 
 43 | export
 44 | parse_pem_blob : Parser PEMBlob
 45 | parse_pem_blob = do
 46 |   takeUntil "-----BEGIN "
 47 |   label' <- many label_char
 48 |   let label = pack label'
 49 |   _ <- string "-----"
 50 |   spaces
 51 |   content <- many ((some base64_char) <* spaces)
 52 |   _ <- string "-----END "
 53 |   _ <- string label
 54 |   _ <- string "-----"
 55 |   spaces
 56 |   case base64_decode $ pack $ concat content of
 57 |     Right str => pure $ MkPEMBlob label str
 58 |     Left  err => fail $ "failed parsing PEM content: " <+> err
 59 | 
 60 | fold_string : String -> String
 61 | fold_string str = pack $ foldl (<+>) [] $ map (<+> ['\n']) $ chunk 64 $ unpack str
 62 | 
 63 | export
 64 | encode_pem_blob : PEMBlob -> String
 65 | encode_pem_blob blob =
 66 |   "-----BEGIN " <+> blob.label <+> "-----\n"
 67 |   <+> (fold_string $ base64_encode blob.content)
 68 |   <+> "-----END " <+> blob.label <+> "-----"
 69 |