Dpapi.hs

{-
 - This Source Code Form is subject to the terms of the Mozilla Public
 - License, v. 2.0. If a copy of the MPL was not distributed with this
 - file, You can obtain one at https://mozilla.org/MPL/2.0/.
 -}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-- on 64-bit Windows, stdcall is deprecated but it's still needed on 32-bit
{-# OPTIONS_GHC -Wno-unsupported-calling-conventions #-}

module System.Win32.Dpapi (cryptProtectData, cryptUnprotectData, cryptUnprotectDataCheck, DataProtectionScope (..)) where

import Control.Exception (catch, finally, throwIO)
import Data.Bits (Bits ((.|.)))
import Data.ByteString (ByteString, packCStringLen, useAsCStringLen)
import Foreign (Ptr, Storable (peek, poke), castPtr, nullPtr)
import Foreign.Marshal (alloca)
import GHC.IO.Exception (IOErrorType (InvalidArgument))
import System.IO.Error (ioeGetErrorType)
import System.Win32.Dpapi.Internal (DataBlob (..))
import System.Win32.Types (BOOL, DWORD, LPCWSTR, failWith, getLastError)

-- | The scope in which data should be protected.
--
-- When encrypting with for the current user,
-- the resulting ciphertext is portable for the same user to decrypt on any device
-- on the domain (at least for domain-joined devices).
-- Obviously, local machine is not portable in that way, but is available for all
-- users on the same device.
data DataProtectionScope = CurrentUser | LocalMachine
  deriving (Show, Eq)

-- hlint loves to complain that I should use camelCase for these
{-# HLINT ignore cRYPTPROTECT_UI_FORBIDDEN #-}
{-# HLINT ignore cRYPTPROTECT_LOCAL_MACHINE #-}
{-# HLINT ignore cRYPTPROTECT_CRED_SYNC #-}
{-# HLINT ignore cRYPTPROTECT_AUDIT #-}
{-# HLINT ignore cRYPTPROTECT_NO_RECOVERY #-}
{-# HLINT ignore cRYPTPROTECT_VERIFY_PROTECTION #-}
-- These just come from the header dpapi.h

cRYPTPROTECT_UI_FORBIDDEN :: DWORD
cRYPTPROTECT_UI_FORBIDDEN = 0x1

cRYPTPROTECT_LOCAL_MACHINE :: DWORD
cRYPTPROTECT_LOCAL_MACHINE = 0x4

cRYPTPROTECT_CRED_SYNC :: DWORD
cRYPTPROTECT_CRED_SYNC = 0x8

cRYPTPROTECT_AUDIT :: DWORD
cRYPTPROTECT_AUDIT = 0x10

cRYPTPROTECT_NO_RECOVERY :: DWORD
cRYPTPROTECT_NO_RECOVERY = 0x20

cRYPTPROTECT_VERIFY_PROTECTION :: DWORD
cRYPTPROTECT_VERIFY_PROTECTION = 0x40

-- data CryptProtectPromptStruct = CryptProtectPromptStruct
--   { cbSize :: DWORD,
--     dwPromptFlags :: DWORD,
--     hwndApp :: HWND,
--     szPrompt :: LPCWSTR
--   }

{-
    https://learn.microsoft.com/en-us/windows/win32/api/dpapi/nf-dpapi-cryptprotectdata
    BOOL CryptProtectData(
      [in]           DATA_BLOB                 *pDataIn,
      [in, optional] LPCWSTR                   szDataDescr,
      [in, optional] DATA_BLOB                 *pOptionalEntropy,
      [in]           PVOID                     pvReserved,
      [in, optional] CRYPTPROTECT_PROMPTSTRUCT *pPromptStruct,
      [in]           DWORD                     dwFlags,
      [out]          DATA_BLOB                 *pDataOut
    );
-}
foreign import stdcall unsafe "CryptProtectData"
  foreign_CryptProtectData :: Ptr DataBlob -> LPCWSTR -> Ptr DataBlob -> Ptr () -> Ptr () -> DWORD -> Ptr DataBlob -> IO BOOL

{-
    BOOL CryptUnprotectData(
      [in]            DATA_BLOB                 *pDataIn,
      [out, optional] LPWSTR                    *ppszDataDescr,
      [in, optional]  DATA_BLOB                 *pOptionalEntropy,
                      PVOID                     pvReserved,
      [in, optional]  CRYPTPROTECT_PROMPTSTRUCT *pPromptStruct,
      [in]            DWORD                     dwFlags,
      [out]           DATA_BLOB                 *pDataOut
    );
-}
foreign import stdcall unsafe "CryptUnprotectData"
  foreign_CryptUnprotectData :: Ptr DataBlob -> LPCWSTR -> Ptr DataBlob -> Ptr () -> Ptr () -> DWORD -> Ptr DataBlob -> IO BOOL

-- Required instead of just using `free` since that's how Windows allocates it
foreign import stdcall unsafe "LocalFree"
  foreign_LocalFree :: Ptr a -> IO (Ptr a)

-- checkCrypt fn text null1 entropy null2 null3 flags out
--   | flags /= 1 && flags /= 5 = do
--       putStrLn $ "bad flags " <> show flags
--       pure False
--   | null1 /= nullPtr || null2 /= nullPtr || null3 /= nullPtr = do
--       putStrLn "expected nullptr"
--       pure False
--   | text == nullPtr = do
--       putStrLn "no input"
--       pure False
--   | out == nullPtr = do
--       putStrLn "no output"
--       pure False
--   | otherwise = do
--       textBlob@(DataBlob textBlobLen textBlobPtr) <- peek text
--       if textBlobPtr == nullPtr
--         then putStrLn "input nullptr in struct" *> pure False
--         else do
--           outBlob@(DataBlob outBlobLen outBlobPtr) <- peek out
--           if outBlobPtr == nullPtr
--             then putStrLn "output nullptr in struct" *> pure False
--             else
--               if entropy == nullPtr
--                 then
--                   fn text null1 entropy null2 null3 flags out
--                 else do
--                   entropyBlob@(DataBlob entropyBlobLen entropyBlobPtr) <- peek entropy
--                   if entropyBlobPtr == nullPtr
--                     then putStrLn "entropy nullptr in struct" *> pure False
--                     else
--                       fn text null1 entropy null2 null3 flags out

-- | Protect some plaintext and return some ciphertext
--
-- If provided, the same source of entropy must be used for both encryption and decryption.
-- Maybe you're prompting the user for a second password or something,
-- but don't save the extra entropy somewhere with DPAPI, that would defeat the point.
cryptProtectData ::
  -- | The plaintext to be protected
  ByteString ->
  -- | Optionally, some bytes to be used as extra entropy
  Maybe ByteString ->
  -- | Whether to protect with the user's credentials or the machine credentials
  DataProtectionScope ->
  -- | The cipertext for you to save somewhere else
  IO ByteString
cryptProtectData = fromDataResult True

-- | Retrieve the plaintext from some previously-encrypted ciphertext.
--
-- If any extra entropy was used, the same entropy must be reused during decryption.
-- Likewise, the same scope must be used.
cryptUnprotectData ::
  -- | The ciphertext
  ByteString ->
  -- | Any entropy that was used for encryption
  Maybe ByteString ->
  -- | The scope this was protected using
  DataProtectionScope ->
  -- | The plaintext
  IO ByteString
cryptUnprotectData = fromDataResult False

-- | A wrapper around `cryptUnprotectData` that returns Nothing if the\
-- ciphertext cannot be decrypted. This does not trap all errors,
-- just those resulting from invalid arguments that cannot be decrypted.
cryptUnprotectDataCheck ::
  -- | The ciphertext
  ByteString ->
  -- | Any entropy that was used for encryption
  Maybe ByteString ->
  -- | The scope this was protected using
  DataProtectionScope ->
  -- | The plaintext
  IO (Maybe ByteString)
cryptUnprotectDataCheck text entropy scope = catch (Just <$> fromDataResult False text entropy scope) $ \(err :: IOError) ->
  if ioeGetErrorType err == InvalidArgument then pure Nothing else throwIO err

fromDataResult :: Bool -> ByteString -> Maybe ByteString -> DataProtectionScope -> IO ByteString
fromDataResult protect inputbytes entropybytes scope =
  -- withBlobFromByteString text $ \t -> with t $ \textblob ->
  --   liftMaybeContinue withBlobFromByteString entropy $ \e -> liftMaybeContinue with e $ \entropyBlob -> do
  --     -- initialPtr <- malloc
  --     with (DataBlob 0 nullPtr) $ \result -> do
  useAsCStringLen inputbytes $ \(cstr, textlen) ->
    alloca $ \inputPtr ->
      alloca $ \resultPtr ->
        allocaEntropy $ \entropyPtr -> do
          poke inputPtr $ DataBlob (fromIntegral textlen) (castPtr cstr)
          -- poke resultPtr $ DataBlob 0 nullPtr
          -- peek resultPtr >>= \(DataBlob dataLen dataPtr) ->
          --   putStrLn $ "staring with " <> show dataLen <> " @ " <> show dataPtr

          success <- foreignFunc inputPtr nullPtr entropyPtr nullPtr nullPtr (fromScope scope) resultPtr
          withResult success =<< peek resultPtr
  where
    withResult success (DataBlob dataLen dataPtr) = do
      -- (DataBlob dataLen dataPtr) <- peek resultPtr
      flip finally (foreign_LocalFree dataPtr) $
        if success
          then packCStringLen (castPtr dataPtr, fromIntegral dataLen)
          else do
            err <- getLastError
            failWith (name <> ": " <> show err) err
    allocaEntropy m =
      case entropybytes of
        (Just bs) -> useAsCStringLen bs $ \(cstr, textlen) -> alloca $ \entropyPtr -> do
          poke entropyPtr $ DataBlob (fromIntegral textlen) (castPtr cstr)
          m entropyPtr
        Nothing -> m nullPtr
    foreignFunc = if protect then foreign_CryptProtectData else foreign_CryptUnprotectData
    -- liftMaybeContinue :: (t1 -> (t2 -> a) -> a) -> Maybe t1 -> (Maybe t2 -> a) -> a
    -- liftMaybeContinue _ Nothing k = k Nothing
    -- liftMaybeContinue f (Just a) k = f a (k . Just)
    name = if protect then "cryptProtectData" else "cryptUnprotectData"
    -- Never prompt the user for interaction
    fromScope :: DataProtectionScope -> DWORD
    fromScope LocalMachine = cRYPTPROTECT_UI_FORBIDDEN .|. cRYPTPROTECT_LOCAL_MACHINE
    fromScope CurrentUser = cRYPTPROTECT_UI_FORBIDDEN