Refactored ssh key blob serialization into independent module.

1 files changed, 51 insertions, 0 deletions

diff --git a/SSHKey.hs b/SSHKey.hs
new file mode 100644
index 0000000..6e92e43
--- /dev/null
+++ b/SSHKey.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE OverloadedStrings #-}
+module SSHKey where
+
+import qualified Data.ByteString.Lazy.Char8 as L8
+import qualified Data.ByteString.Lazy as L
+import qualified Codec.Binary.Base64 as Base64
+import Data.Binary.Get ( runGet )
+import Data.Binary.Put ( putWord32be, runPut, putByteString )
+import Data.Binary     ( get, put )
+import Data.Monoid     ( (<>) )
+import Data.Maybe      ( fromMaybe, listToMaybe )
+import Data.Char       ( isSpace )
+import Control.Monad   ( guard )
+import LengthPrefixedBE
+
+type Key = (Integer,Integer)
+
+keyblob :: Key -> L.ByteString
+keyblob (n,e) = "ssh-rsa " <> blob
+ where
+    bs = sshrsa e n
+    blob = L8.pack $ Base64.encode (L.unpack bs)
+
+    sshrsa :: Integer -> Integer -> L.ByteString
+    sshrsa e n = runPut $ do
+        putWord32be 7
+        putByteString "ssh-rsa"
+        put (LengthPrefixedBE e)
+        put (LengthPrefixedBE n)
+
+blobkey :: L8.ByteString -> Key
+blobkey bs = fromMaybe er $ do
+    let (pre,bs1) = L8.splitAt 7 bs
+    guard $ pre == "ssh-rsa"
+    let (sp,bs2) = L8.span isSpace bs1
+    guard $ not (L8.null sp)
+    bs3 <- listToMaybe $ L8.words bs2
+    qq <- L.pack `fmap` Base64.decode (L8.unpack bs3)
+    decode_sshrsa qq
+ where
+    er = error "Unsupported key format"
+
+    decode_sshrsa :: L8.ByteString -> Maybe Key
+    decode_sshrsa bs = do
+        let (pre,bs1) = L8.splitAt 11 bs
+        guard $ pre == runPut (putWord32be 7 >> putByteString "ssh-rsa")
+        let rsakey = flip runGet bs1 $ do
+                LengthPrefixedBE e <- get
+                LengthPrefixedBE n <- get
+                return (n,e)
+        return rsakey