module Main where

import Data.Binary
import Data.OpenPGP
import qualified Data.ByteString.Lazy as L
import Control.Monad
import Text.Show.Pretty
import Data.List
import Data.OpenPGP.CryptoAPI
import Data.Ord
import Data.Maybe
import Data.Bits

getPackets :: IO [Packet]
getPackets = do
    input <- L.getContents
    case decodeOrFail input of
        Right (_,_,Message pkts) -> return pkts
        Left  (_,_,_)            -> return []


isKey (PublicKeyPacket {}) = True
isKey (SecretKeyPacket {}) = True
isKey _                    = False

isUserID (UserIDPacket {}) = True
isUserID _                 = False

isEmbeddedSignature (EmbeddedSignaturePacket {}) = True
isEmbeddedSignature _                            = False

issuer (IssuerPacket issuer) = Just issuer
issuer _                     = Nothing
backsig (EmbeddedSignaturePacket s) = Just s
backsig _                           = Nothing

isSubkeySignature (SubkeySignature {}) = True
isSubkeySignature _                    = False

usage (NotationDataPacket
        { human_readable = True
        , notation_name  = "usage@"
        , notation_value = u
        }) = Just u
usage _    = Nothing

verifyBindings keys []      = []
verifyBindings keys nonkeys = top ++ filter isSubkeySignature embedded
 where
    verified = do
        sig <- signatures (Message nonkeys)
        let v = verify (Message keys) sig
        guard (not . null $ signatures_over v)
        return v
    (top,_) = partition isSubkeySignature verified
    embedded = do
        sub <- top
        let sigover = signatures_over sub
            unhashed = sigover >>= unhashed_subpackets
            subsigs = mapMaybe backsig unhashed
        sig <- signatures (Message ([topkey sub,subkey sub]++subsigs))
        let v = verify (Message [subkey sub]) sig
        guard (not . null $ signatures_over v)
        return v

smallpr k = drop 24 $ fingerprint k

disjoint_fp ks = transpose grouped
 where
    grouped    = groupBy samepr . sortBy (comparing smallpr) $ ks
    samepr a b = smallpr a == smallpr b

getBindings ::
  [Packet]
  -> [(Word8,
       (Packet, Packet),
       [String],
       [SignatureSubpacket],
       [Packet])]
getBindings pkts = do
    let (keys,nonkeys) = partition isKey pkts
    keys <- disjoint_fp (keys)
    b <- verifyBindings keys pkts -- nonkeys
    i <- map signature_issuer (signatures_over b)
    i <- maybeToList i
    who <- maybeToList $ find_key fingerprint (Message keys) i
    let (code,claimants) = 
            case () of
                _ | who == topkey b -> (1,[])
                _ | who == subkey b -> (2,[])
                _                   -> (0,[who])
    let hashed = signatures_over b >>= hashed_subpackets
        kind = guard (code==1) >> hashed >>= maybeToList . usage
    return (code,(topkey b,subkey b), kind, hashed,claimants)

accBindings ::
  Bits t =>
  [(t, (Packet, Packet), [a], [a1], [a2])]
  -> [(t, (Packet, Packet), [a], [a1], [a2])]
accBindings bs = as
  where
    gs = groupBy samePair . sortBy (comparing bindingPair) $ bs
    as = map (foldl1 combine) gs
    bindingPair (_,p,_,_,_) = pub2 p
      where
        pub2 (a,b) = (pub a, pub b)
        pub a = fingerprint_material a
    samePair a b = bindingPair a == bindingPair b
    combine (ac,p,akind,ahashed,aclaimaints)
            (bc,_,bkind,bhashed,bclaimaints)
        = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints)

listKeys pkts = do
    let bs = getBindings pkts
        as = accBindings bs
        defaultkind []    = "subkey"
        defaultkind (k:_) = k
        kinds = map (\(_,_,k,_,_)->defaultkind k) as
        kindwidth = maximum $ map length kinds
        kindcol = min 20 kindwidth
        sameMaster (_,(a,_),_,_,_) (_,(b,_),_,_,_) = fingerprint_material a==fingerprint_material b
        gs = groupBy sameMaster as
    subs <- gs
    let (code,(top,sub), kind, hashed,claimants):_ = subs
        subkeys = do
            (code,(top,sub), kind, hashed,claimants) <- subs
            let ar = case code of
                        0 -> " ??? "
                        1 -> " --> "
                        2 -> " <-- "
                        3 -> " <-> "
                formkind = take kindcol $ defaultkind kind ++ repeat ' '
            " "++smallpr top ++ ar ++ formkind++" "++ fingerprint sub ++"\n"
    "gpg " ++ fingerprint top ++ "\n" ++ subkeys ++ "\n"
    


main = do
    pkts <- getPackets
    putStrLn $ listKeys pkts
    return ()