
   0 | module Network.TLS.Certificate.System
   1 | 
   2 | import Data.Vect
   3 | import Data.Fin
   4 | import Control.Monad.Error.Either
   5 | import Control.Monad.Error.Interface
   6 | import System.Info
   7 | import System.FFI
   8 | import Data.Buffer
   9 | import Data.List
  10 | import Network.TLS.Certificate
  11 | import Network.TLS.Parse.PEM
  12 | import Data.String.Parser
  13 | import Data.Either
  14 | import System.File.Process
  15 | import System.File.ReadWrite
  16 | import System.Directory
  17 | import System
  18 | 
  19 | pem_to_certificate : PEMBlob -> Either String Certificate
  20 | pem_to_certificate (MkPEMBlob "CERTIFICATE" content) =
  21 |   bimap (\err => "error: \{err}, content:\n") id (parse_certificate content)
  22 | pem_to_certificate _ = Left "PEM is not a certificate"
  23 | 
  24 | --- START WINDOWS ---
  25 | 
  26 | %foreign "C:openCertStore,libidristls"
  27 | prim__open_cert_store : PrimIO AnyPtr
  28 | 
  29 | %foreign "C:closeCertStore,libidristls"
  30 | prim__close_cert_store : AnyPtr -> PrimIO Int
  31 | 
  32 | %foreign "C:nextCertInStore,libidristls"
  33 | prim__next_cert_in_store : AnyPtr -> AnyPtr -> PrimIO AnyPtr
  34 | 
  35 | %foreign "C:isNull, libidris2_support, idris_support.h"
  36 | prim__idrnet_isNull : (ptr : AnyPtr) -> PrimIO Int
  37 | 
  38 | %foreign "C:certLenInfo,libidristls"
  39 | prim__cert_len_info : AnyPtr -> PrimIO Int
  40 | 
  41 | %foreign "C:certBody,libidristls"
  42 | prim__cert_body : AnyPtr -> Buffer -> PrimIO ()
  43 | 
  44 | nullPtr : HasIO io => AnyPtr -> io Bool
  45 | nullPtr p = do
  46 |   i <- primIO $ prim__idrnet_isNull p
  47 |   pure (i /= 0)
  48 | 
  49 | buffer_to_list : HasIO io => Buffer -> io (List Bits8)
  50 | buffer_to_list buffer = rawSize buffer >>= \cap => traverse (getBits8 buffer) [0..(cap-1)]
  51 | 
  52 | test_windows_cert : EitherT String IO (List Certificate)
  53 | test_windows_cert = do
  54 |   cert_store <- primIO prim__open_cert_store
  55 |   certs <- loop [] cert_store prim__getNullAnyPtr
  56 | 
  57 |   let certs_parsed = mapMaybe (getRight . parse_certificate) certs
  58 | 
  59 |   b <- primIO $ prim__close_cert_store cert_store
  60 |   if b == 0
  61 |     then throwE "error occured while closing certificate store"
  62 |     else pure certs_parsed
  63 |   where
  64 |     loop : HasIO io => List (List Bits8) -> AnyPtr -> AnyPtr -> io (List (List Bits8))
  65 |     loop acc cert_store prev_cert = do
  66 |       ctxptr <- primIO $ prim__next_cert_in_store cert_store prev_cert
  67 |       False <- nullPtr ctxptr
  68 |       | True => pure acc
  69 |       len <- primIO $ prim__cert_len_info ctxptr
  70 |       Just buffer <- newBuffer len
  71 |       | Nothing => loop acc cert_store ctxptr
  72 |       primIO $ prim__cert_body ctxptr buffer
  73 |       buffer_to_list buffer >>= \cert => loop (cert :: acc) cert_store ctxptr
  74 | 
  75 | --- END WINDOWS ---
  76 | 
  77 | --- START MACOS ---
  78 | 
  79 | rootCAKeyChain : String
  80 | rootCAKeyChain = "/System/Library/Keychains/SystemRootCertificates.keychain"
  81 | 
  82 | systemKeyChain : String
  83 | systemKeyChain = "/Library/Keychains/System.keychain"
  84 | 
  85 | command : List String
  86 | command = ["security", "find-certificate", "-pa", rootCAKeyChain, systemKeyChain]
  87 | 
  88 | read_pems : EitherT FileError IO String
  89 | read_pems = do
  90 |   file <- MkEitherT (popen command Read)
  91 |   MkEitherT (fRead file)
  92 | 
  93 | test_macos_cert : EitherT String IO (List Certificate)
  94 | test_macos_cert = do
  95 |   pems <- bimapEitherT (\err => "popen security failed: \{show err}") id read_pems
  96 |   (pemblobs, _) <- MkEitherT $ pure $ parse (many parse_pem_blob) pems
  97 |   pure (mapMaybe (getRight . pem_to_certificate) pemblobs)
  98 | 
  99 | --- END MACOS ---
 100 | 
 101 | --- START UNIX ---
 102 | 
 103 | default_paths : List String
 104 | default_paths =
 105 |   [ "/etc/ssl/certs/"                 -- linux
 106 |   , "/system/etc/security/cacerts/"   -- android
 107 |   , "/usr/local/share/certs/"         -- freebsd
 108 |   , "/etc/ssl/cert.pem"               -- openbsd
 109 |   ]
 110 | 
 111 | to_files : HasIO io => List String -> io (List String)
 112 | to_files folders = join <$> traverse go folders where
 113 |   go : String -> io (List String)
 114 |   go folder = case !(listDir folder) of
 115 |     Left _ => pure [folder]
 116 |     Right files => pure (map (folder <+> "/" <+>) files)
 117 | 
 118 | test_unix_certs : EitherT String IO (List Certificate)
 119 | test_unix_certs = do
 120 |   folder <- maybe default_paths (::[]) <$> getEnv "SYSTEM_CERTIFICATE_PATH"
 121 |   certpaths <- to_files folder
 122 |   pemtxts <- mapMaybe getRight <$> traverse readFile certpaths
 123 |   let pems = pemtxts >>= parse_pems_ignore_error
 124 |   pure (mapMaybe (getRight . pem_to_certificate) pems)
 125 |   where
 126 |     parse_pems_ignore_error : String -> List PEMBlob
 127 |     parse_pems_ignore_error = either (const []) fst . parse (many parse_pem_blob)
 128 | 
 129 | --- END UNIX
 130 | 
 131 | export
 132 | get_system_trusted_certs : IO (Either String (List Certificate))
 133 | get_system_trusted_certs =
 134 |   runEitherT $ if isWindows
 135 |      then test_windows_cert
 136 |      else (if os == "darwin" then test_macos_cert else test_unix_certs)
 137 |