parse email-style Date: headers when importing PEM files.

2 files changed, 35 insertions, 5 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index e0c3b77..94039f6 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -113,7 +113,7 @@ import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1
 import Data.ASN1.BitArray ( BitArray(..), toBitArray )
 import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1, decodeASN1' )
 import Data.ASN1.BinaryEncoding ( DER(..) )
-import Data.Time.Clock.POSIX ( POSIXTime, utcTimeToPOSIXSeconds )
+import Data.Time.Clock.POSIX ( POSIXTime, utcTimeToPOSIXSeconds, posixSecondsToUTCTime )
 import Data.Time.Clock ( UTCTime )
 import Data.Bits ( Bits )
 import Data.Text.Encoding ( encodeUtf8 )
@@ -1500,9 +1500,9 @@ readSecretPEMFile fname = do
     let ctx = InputFileContext "" ""
     -- Note: The key's timestamp is included in it's fingerprint.
     --       Therefore, we should attempt to preserve it.
-    timestamp <- getInputFileTime ctx fname
+    stamp <- getInputFileTime ctx fname
     input <- readInputFileL ctx fname
-    let dta = catMaybes $ scanAndParse (pkcs1 <> cert) $ Char8.lines input
+    let edta = scanAndParse (fmap Left dateParser <> fmap Right (pkcs1 <> cert)) $ Char8.lines input
         pkcs1 = fmap (parseRSAPrivateKey . pemBlob)
                     $ pemParser $ Just "RSA PRIVATE KEY"
         cert  = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob)
@@ -1514,7 +1514,7 @@ readSecretPEMFile fname = do
            let _ = rsa :: RSAPrivateKey
            return $ PEMPacket $ SecretKeyPacket
                 { version = 4
-                , timestamp = toEnum (fromEnum timestamp)
+                , timestamp = fromTime stamp -- toEnum (fromEnum stamp)
                 , key_algorithm = RSA
                 , key = [ -- public fields...
                          ('n',rsaN rsa)
@@ -1532,7 +1532,14 @@ readSecretPEMFile fname = do
                 , encrypted_data = ""
                 , is_subkey = True
                 }
-    return dta
+        dta = catMaybes $ map snd $ scanl mergeDate (stamp,Nothing) edta
+        mergeDate (_,obj) (Left tm) = (fromTime tm,obj)
+        mergeDate (tm,_) (Right (Just (PEMPacket key))) = (tm,Just $ PEMPacket key')
+            where key' = if tm < fromTime (timestamp key)
+                            then key { timestamp = fromTime tm }
+                            else key
+        mergeDate (tm,_) (Right mb) = (tm,mb)
+    return $ dta
 
 doImport
   :: Ord k =>
diff --git a/TimeUtil.hs b/TimeUtil.hs
index 1c241a4..9c0a2b5 100644
--- a/TimeUtil.hs
+++ b/TimeUtil.hs
@@ -3,8 +3,10 @@
 module TimeUtil
     ( now
     , IsTime(..)
+    , fromTime
     , parseRFC2822
     , printRFC2822
+    , dateParser
     ) where
 
 import Data.Time.LocalTime
@@ -18,6 +20,8 @@ import Data.Maybe
 import Data.Char
 import qualified Data.ByteString.Char8 as S
 import qualified Data.ByteString.Lazy.Char8 as L
+import Foreign.C.Types ( CTime(..) )
+import Data.Word ( Word32 )
 
 import ScanningParser
 
@@ -89,6 +93,25 @@ dateParser = ScanningParser ffst pbdy
           else Nothing
     pbdy date xs = (date,xs)
 
+class IsUTC a where
+    fromUTC :: UTCTime -> a
+    toUTC :: a -> UTCTime
+
+fromTime :: ( IsUTC a, IsUTC b ) => a -> b
+fromTime = fromUTC . toUTC
+
+instance IsUTC UTCTime where
+    fromUTC = id
+    toUTC = id
+
+instance IsUTC CTime where
+    fromUTC utc = CTime (round $ utcTimeToPOSIXSeconds utc)
+    toUTC (CTime t) = posixSecondsToUTCTime (realToFrac t)
+
+instance IsUTC Word32 where
+    fromUTC utc = round $ utcTimeToPOSIXSeconds utc
+    toUTC t = posixSecondsToUTCTime (realToFrac t)
+
 {-
 main = do
     nowtime <- now