-- |
-- Module      : Crypto.Longshot.TH
-- License     : MIT
-- Maintainer  : Francis Lim <thyeem@gmail.com>
-- Stability   : experimental
-- Portability : unknown
--
module Crypto.Longshot.TH where

import           Control.Monad                  ( replicateM )
import           Data.Foldable                  ( foldl' )
import           Data.ByteString.Char8          ( unpack )
import           Language.Haskell.TH
import           Crypto.Longshot.Const

-- | Brute-force with N-search-length using TH
bruteforceN :: Int -> Q Exp -> Q Exp -> Q Exp -> Q Exp -> Q Exp
bruteforceN :: Int -> Q Exp -> Q Exp -> Q Exp -> Q Exp -> Q Exp
bruteforceN Int
numBind Q Exp
chars Q Exp
hex Q Exp
hasher Q Exp
prefix = do
  [Name]
names <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
numBind (String -> Q Name
newName String
"names")
  let pats :: [PatQ]
pats  = Name -> PatQ
varP (Name -> PatQ) -> [Name] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
names
  let bytes :: [Q Exp]
bytes = Q Exp
prefix Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Name -> Q Exp
varE (Name -> Q Exp) -> [Name] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
names)
  let preimage :: Q Exp
preimage = [| $( foldl' (\a b -> [| $a <> $b |]) [| mempty |] bytes ) |]
  let cond :: Q Exp
cond  = Q Exp -> Q Exp -> Q Exp -> Q Exp
condE [| $( appE hasher preimage ) == $( hex ) |]
                    [| Just (unpack $( preimage )) |]
                    [| Nothing |]
  let stmts :: [StmtQ]
stmts = ((PatQ -> Q Exp -> StmtQ
`bindS` Q Exp
chars) (PatQ -> StmtQ) -> [PatQ] -> [StmtQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PatQ]
pats) [StmtQ] -> [StmtQ] -> [StmtQ]
forall a. Semigroup a => a -> a -> a
<> [Q Exp -> StmtQ
noBindS Q Exp
cond]
  [| foldl' (<|>) empty $( compE stmts ) |]

-- | Declare functions to run in parallel for search
funcGenerator :: Q [Dec]
funcGenerator :: Q [Dec]
funcGenerator = (Int -> Q Dec) -> [Int] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Int -> Q Dec
funcG [Int
0 .. Int
maxNumBind] where
  funcG :: Int -> Q Dec
funcG Int
numBind = do
    let name :: Name
name = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"bruteforce" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
numBind
    Name
chars <- String -> Q Name
newName String
"chars"
    Name
hex <- String -> Q Name
newName String
"hex"
    Name
hasher <- String -> Q Name
newName String
"hasher"
    Name
prefix <- String -> Q Name
newName String
"prefix"
    Name -> [ClauseQ] -> Q Dec
funD Name
name 
      [ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
chars, Name -> PatQ
varP Name
hex, Name -> PatQ
varP Name
hasher, Name -> PatQ
varP Name
prefix] 
        (Q Exp -> BodyQ
normalB (Int -> Q Exp -> Q Exp -> Q Exp -> Q Exp -> Q Exp
bruteforceN Int
numBind (Name -> Q Exp
varE Name
chars) (Name -> Q Exp
varE Name
hex) (Name -> Q Exp
varE Name
hasher) (Name -> Q Exp
varE Name
prefix))) 
        []
      ]

-- | Get list of functions to run in parallel for search
funcList :: Q Exp
funcList :: Q Exp
funcList = [Q Exp] -> Q Exp
listE (Name -> Q Exp
varE (Name -> Q Exp) -> (Int -> Name) -> Int -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Name) -> (Int -> String) -> Int -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"bruteforce" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Q Exp) -> [Int] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
0 .. Int
maxNumBind])