├── .gitignore ├── Convert ├── LDAG │ ├── DOT.hs │ └── JSON.hs └── Misc │ └── String.hs ├── Cryptol ├── FSM.hs └── ModuleM.hs ├── Data ├── LDAG.hs └── MBP.hs ├── LICENSE ├── Options.hs ├── README.md ├── Setup.hs ├── cryfsm.cabal ├── cryfsm.hs ├── examples ├── hamming-obf.cry ├── hamming.cry ├── hamming3.cry ├── ore-clt.cry ├── ore-gghlite.cry ├── ore.cry ├── util.cry └── xor.cry ├── fsmevade.hs ├── images ├── Makefile ├── comparison-base3.cry ├── comparison-base3.png ├── comparison-vanilla.cry └── comparison-vanilla.png └── numfsm.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox 2 | *.dot 3 | /*.cry 4 | *.json 5 | -------------------------------------------------------------------------------- /Convert/LDAG/DOT.hs: -------------------------------------------------------------------------------- 1 | module Convert.LDAG.DOT (convert) where 2 | 3 | import Control.Lens ((^.), (<.>), (<.), each, itoListOf) 4 | import Convert.Misc.String (NodeLabel, showBool, showNodeLabel) 5 | import Data.Graph.Inductive.Graph (Graph, mkGraph) 6 | import Data.Graph.Inductive.PatriciaTree (Gr) 7 | import Data.GraphViz (GraphvizParams(clusterBy, clusterID, fmtCluster, fmtNode, fmtEdge, isDotCluster), 8 | GlobalAttributes(GraphAttrs), GraphID(Num), NodeCluster(N, C), Number(Int), 9 | dashed, graphToDot, defaultParams, printDotGraph, rounded, style, toLabel) 10 | import Data.LDAG (LDAG, LayerID, allNodes, allLayers, nodeLabel, outgoing, dead) 11 | import Data.List (group) 12 | import Data.String (fromString) 13 | import Data.Text.Lazy (Text) 14 | import Data.Universe.Class (Finite, universeF) 15 | import qualified Data.IntMap as IM 16 | 17 | -- | (!) assumes that the nodes at different layers have different IDs 18 | convert :: LDAG NodeLabel Bool -> [String] -> Text 19 | convert ldag grouping 20 | = printDotGraph 21 | . graphToDot (showParams grouping) 22 | . toFGLGr 23 | $ ldag 24 | 25 | toFGLGr :: Finite e => LDAG n e -> Gr (LayerID, Bool, n) e 26 | toFGLGr = toFGL 27 | 28 | toFGL :: (Graph gr, Finite e) => LDAG n e -> gr (LayerID, Bool, n) e 29 | toFGL ldag = mkGraph ns es where 30 | ns = [ (nodeID, (layerID, node ^. dead, node ^. nodeLabel)) 31 | | ((layerID, nodeID), node) 32 | <- itoListOf (allLayers <.> allNodes) ldag 33 | ] 34 | es = [ (fromNodeID, children edgeLabel, edgeLabel) 35 | | (fromNodeID, children) 36 | <- itoListOf (allLayers . allNodes <. outgoing . each) ldag 37 | , edgeLabel <- universeF 38 | ] 39 | 40 | showParams :: [String] -> GraphvizParams n (LayerID, Bool, NodeLabel) Bool (Int, String) (Bool, NodeLabel) 41 | showParams grouping = defaultParams 42 | { clusterBy = \(n, (layerID, dead, bs)) -> C (indexOf layerID) (N (n, (dead, bs))) 43 | , isDotCluster = \_ -> True 44 | , clusterID = \(n, _) -> Num (Int n) 45 | , fmtCluster = \(_, pos) -> [GraphAttrs [style rounded, toLabel pos]] 46 | , fmtNode = \(_, (dead, bs)) -> [style dashed | dead] 47 | ++ [toLabel . showNodeLabel $ bs] 48 | , fmtEdge = \(_, _, el) -> [toLabel . showBool $ el] 49 | } where 50 | indexOf layerID = groups !! max 0 (layerID-1) 51 | groups = concatMap (\(uniq, vals) -> map ((,) uniq) vals) 52 | . zip [0..] 53 | . group 54 | . cycle 55 | $ grouping 56 | -------------------------------------------------------------------------------- /Convert/LDAG/JSON.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Convert.LDAG.JSON (convert) where 3 | 4 | import Control.Lens ((^.), (^..), (<.), _2, asIndex, at, filtered, itraversed, to) 5 | import Convert.Misc.String (NodeLabel, showBools, showNodeLabel) 6 | import Data.Aeson (Value, (.=), object, toJSON) 7 | import Data.Aeson.Encode (encodeToTextBuilder) 8 | import Data.Aeson.Types (Pair) 9 | import Data.Function (on) 10 | import Data.LDAG 11 | import Data.List (groupBy, nub) 12 | import Data.Maybe (catMaybes) 13 | import Data.String (fromString) 14 | import Data.Text.Lazy (Text) 15 | import Data.Text.Lazy.Builder (toLazyText) 16 | import Data.Universe.Class (Finite(universeF)) 17 | 18 | import qualified Data.IntMap as IM 19 | import qualified Data.Map as M 20 | 21 | -- | (!) assumes there is at least one layer 22 | convert :: LDAG NodeLabel Bool -> [String] -> Text 23 | convert ldag grouping 24 | = toLazyText . encodeToTextBuilder 25 | $ ldagGroupingToValue ldag grouping 26 | 27 | ldagGroupingToValue ldag grouping = object 28 | [ "steps" .= stepsToValue (ldagGroupingToSteps ldag grouping) 29 | , "outputs" .= [outputs ldag] 30 | ] 31 | 32 | ldagGroupingToSteps :: (Eq pos, Finite e, Ord e) 33 | => LDAG n e -> [pos] -> [(pos, [([e], [[Bool]])])] 34 | ldagGroupingToSteps ldag grouping 35 | = findAllPaths 36 | . map (\pairs@((_, label):_) -> (label, map fst pairs)) 37 | . groupBy ((==) `on` snd) 38 | $ zip (ldag ^.. allLayers) (cycle grouping) 39 | 40 | -- (!) assumes each grouping has at least one layer 41 | findAllPaths ((label, layers):groups@((_, layer':_):_)) 42 | = (label, findPathsTo (nodeIDs layer') layers) : findAllPaths groups 43 | findAllPaths [(label, layers@(_:_:_))] 44 | = [(label, findPathsTo (nodeIDs (last layers)) (init layers))] 45 | findAllPaths _ = [] 46 | 47 | findPathsTo :: (Finite e, Ord e) => [NodeID] -> [Layer n e] -> [([e], [[Bool]])] 48 | findPathsTo endNodeIDs layers = 49 | filter nonZero 50 | [ (path, [ [ maybeEndNodeID == Just endNodeID 51 | | endNodeID <- endNodeIDs 52 | ] 53 | | startNodeID <- nodeIDs (head layers) 54 | , let maybeEndNodeID = transition startNodeID path layers 55 | ] 56 | ) 57 | | path <- mapM (const universeF) layers 58 | ] 59 | where 60 | nonZero = or . map or . snd 61 | 62 | nodeIDs :: Layer n e -> [NodeID] 63 | nodeIDs layer = layer ^.. (allNodes <. dead . filtered not) . asIndex 64 | 65 | transition :: Ord e => NodeID -> [e] -> [Layer n e] -> Maybe NodeID 66 | transition nodeID [] [] = Just nodeID 67 | transition nodeID (e:es) (layer:layers) = do 68 | node <- layer ^. at nodeID 69 | children <- node ^. outgoing 70 | transition (children e) es layers 71 | transition nodeID _ _ = Nothing 72 | 73 | stepsToValue :: [(String, [([Bool], [[Bool]])])] -> Value 74 | stepToValue :: (String, [([Bool], [[Bool]])]) -> Value 75 | stepsToValue = toJSON . map stepToValue 76 | stepToValue (position, mappings) = object 77 | $ "position" .= position 78 | : map mappingToPair mappings 79 | 80 | mappingToPair :: ([Bool], [[Bool]]) -> Pair 81 | mappingToPair (label, matrix) = k .= v where 82 | k = fromString (showBools label) 83 | v = map (map fromEnum) matrix 84 | 85 | outputs :: LDAG NodeLabel e -> [String] 86 | outputs ldag = ldag ^.. layers . to IM.findMax . _2 . allNodes . filtered (not . (^. dead)) . nodeLabel . to showNodeLabel 87 | -------------------------------------------------------------------------------- /Convert/Misc/String.hs: -------------------------------------------------------------------------------- 1 | module Convert.Misc.String 2 | ( NodeLabel 3 | , showNodeLabel 4 | , showValue 5 | , showBools 6 | , showBool 7 | ) where 8 | 9 | import Cryptol.Utils.PP (pretty) 10 | import Cryptol.Eval.Value (Value, WithBase(WithBase), defaultPPOpts, useAscii) 11 | 12 | type NodeLabel = Either [Bool] Value 13 | 14 | showNodeLabel :: NodeLabel -> String 15 | showNodeLabel = either showBools showValue 16 | 17 | showValue :: Value -> String 18 | showValue = pretty . WithBase defaultPPOpts { useAscii = True } 19 | 20 | showBools :: [Bool] -> String 21 | showBools = concatMap showBool 22 | 23 | showBool :: Bool -> String 24 | showBool False = "0" 25 | showBool True = "1" 26 | -------------------------------------------------------------------------------- /Cryptol/FSM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | module Cryptol.FSM 3 | ( SimpleType(..) 4 | , fromSimpleType 5 | , toSimpleType 6 | , checkExprSimpleType 7 | , ExprBuilderParams 8 | , getExprBuilderParams 9 | , evalSaturated 10 | , step 11 | , checkEquality 12 | , checkDead 13 | , validityAscription 14 | ) where 15 | 16 | import Control.Exception (assert) 17 | import Cryptol.Eval.Type (evalType) 18 | import Cryptol.Eval.Value (Value) 19 | import Cryptol.ModuleM (ModuleM, checkExpr, evalExpr, getEvalEnv, getPrimMap, satProve, renameInteractive, typeCheckInteractive) 20 | import Cryptol.ModuleSystem.Name (lookupPrimDecl) 21 | import Cryptol.ModuleSystem.Renamer (rename) 22 | import Cryptol.Parser (ParseError, parseSchema) 23 | import Cryptol.Parser.Position (emptyRange) 24 | import Cryptol.Symbolic (ProverCommand(ProverCommand), ProverResult(AllSatResult, ThmResult, ProverError), QueryType(SatQuery), SatNum(SomeSat), pcExpr, pcExtraDecls, pcProverName, pcQueryType, pcSchema, pcSmtFile, pcVerbose) 25 | import Cryptol.TypeCheck.Solver.InfNat (Nat'(Nat)) 26 | import Cryptol.Utils.Ident (packIdent) 27 | import Cryptol.Utils.PP (pretty) 28 | import Data.List (genericLength) 29 | import Data.String (fromString) 30 | import qualified Cryptol.Eval.Value as E 31 | import qualified Cryptol.Parser.AST as P 32 | import qualified Cryptol.TypeCheck.AST as TC 33 | 34 | data SimpleType = SimpleType 35 | { inputBits :: Integer 36 | , outputType :: E.TValue 37 | } 38 | 39 | fromSimpleType :: SimpleType -> TC.Schema 40 | fromSimpleType (SimpleType n out) = TC.Forall 41 | { TC.sVars = [] 42 | , TC.sProps = [] 43 | , TC.sType = TC.tFun (TC.tSeq (TC.tNum n) TC.tBit) (E.tValTy out) 44 | } 45 | 46 | toSimpleType :: TC.Schema -> ModuleM SimpleType 47 | toSimpleType schema = do 48 | env <- getEvalEnv 49 | case schema of 50 | TC.Forall [] _ ty -> case evalType env ty of 51 | (E.isTFun -> Just (E.isTSeq -> Just (E.numTValue -> Nat n, E.isTBit -> True), out)) -> do 52 | let simpleTy = SimpleType n out 53 | prettyTy = pretty (fromSimpleType simpleTy) 54 | schema <- tvalueToSchema out 55 | case schema of 56 | Right (P.Forall [] [] pty _) -> simpleTy <$ ensureCmp pty 57 | Left parseError -> fail ("Bug: couldn't parse " ++ prettyTy ++ " as a schema") 58 | Right s -> fail ("Bug: monomorphic type " ++ prettyTy ++ " was parsed as polymorphic") 59 | _ -> fail ("unsupported type " ++ pretty ty) 60 | _ -> fail ("unsupported polymorphic type " ++ pretty schema) 61 | 62 | checkExprSimpleType :: P.Expr P.PName -> ModuleM (TC.Expr, SimpleType) 63 | checkExprSimpleType e = checkExpr e >>= traverse toSimpleType 64 | 65 | tvalueToSchema :: E.TValue -> ModuleM (Either ParseError (P.Schema TC.Name)) 66 | tvalueToSchema 67 | = traverse (renameInteractive . rename) 68 | . parseSchema 69 | . fromString 70 | . pretty 71 | . E.tValTy 72 | 73 | ensureCmp :: P.Type TC.Name -> ModuleM () 74 | ensureCmp pty = do 75 | pm <- getPrimMap 76 | let eq = P.EVar (lookupPrimDecl (packIdent "==") pm) `P.ETyped` 77 | (pty `P.TFun` (pty `P.TFun` P.TBit)) 78 | () <$ typeCheckInteractive eq 79 | 80 | data ExprBuilderParams = ExprBuilderParams 81 | { freshVar :: TC.Name 82 | , cryptolTrue :: TC.Expr 83 | , cryptolFalse :: TC.Expr 84 | , cryptolCat :: TC.Expr 85 | , cryptolNeq :: TC.Expr 86 | , cryptolAnd :: TC.Expr 87 | , cryptolOr :: TC.Expr 88 | } 89 | 90 | getExprBuilderParams :: ModuleM ExprBuilderParams 91 | getExprBuilderParams = do 92 | -- TODO: this is a terrible hack; all we really want is a fresh name and 93 | -- there has to be a better way to get one 94 | (TC.EAbs x _ _, _) <- checkExpr cryptolId 95 | pm <- getPrimMap 96 | let [true, false, cat, neq, and, or] = TC.ePrim pm . packIdent <$> ["True", "False", "#", "!=", "&&", "||"] 97 | return (ExprBuilderParams x true false cat neq and or) 98 | 99 | cryptolId :: P.Expr P.PName 100 | cryptolId = P.EFun [P.PVar (P.Located emptyRange (ident "x"))] (P.ETyped (evar "x") P.TBit) 101 | 102 | evalSaturated :: ExprBuilderParams -> Integer -> TC.Expr -> [Bool] -> ModuleM (Either [Bool] Value) 103 | evalSaturated params nin e bs = if genericLength bs == nin 104 | then Right <$> evalExpr (TC.EApp e (liftBools params bs)) 105 | else return (Left bs) 106 | 107 | sat :: String -> (TC.Expr, SimpleType) -> ModuleM Bool 108 | sat solver (expr, simpleTy) = do 109 | res <- satProve ProverCommand 110 | { pcQueryType = SatQuery (SomeSat 1) 111 | , pcProverName = solver 112 | , pcVerbose = False 113 | , pcExtraDecls = [] 114 | , pcSmtFile = Nothing 115 | , pcExpr = expr 116 | , pcSchema = fromSimpleType simpleTy 117 | } 118 | case res of 119 | ThmResult _ -> return False 120 | AllSatResult _ -> return True 121 | ProverError e -> fail e 122 | _ -> fail "SAT solver did something weird" 123 | 124 | step :: Integer -> [Bool] -> Maybe (Bool -> [Bool]) 125 | step n xs | genericLength xs < n = Just (\x -> xs ++ [x]) 126 | | otherwise = Nothing 127 | 128 | checkEquality :: ExprBuilderParams -> String -> (TC.Expr, SimpleType) -> (TC.Expr, SimpleType) -> [Bool] -> [Bool] -> ModuleM Bool 129 | checkEquality params solver unapplied valid l r 130 | = fmap not 131 | . sat solver 132 | $ equalityCondition params unapplied valid l r 133 | 134 | checkDead :: ExprBuilderParams -> String -> (TC.Expr, SimpleType) -> [Bool] -> ModuleM Bool 135 | checkDead params solver valid bs 136 | = fmap not 137 | . sat solver 138 | $ validCondition params valid bs 139 | 140 | -- (!) assumes `length l == length r` 141 | -- (!) assumes `length l <= nin` 142 | -- (!) assumes the two `SimpleType`s have equal input lengths 143 | equalityCondition :: ExprBuilderParams -> (TC.Expr, SimpleType) -> (TC.Expr, SimpleType) -> [Bool] -> [Bool] -> (TC.Expr, SimpleType) 144 | equalityCondition params (unapplied, SimpleType nin out) (valid, _) l r 145 | = assert (nl == nr && nl <= nin) 146 | $ (abstraction, SimpleType nfresh tvBit) 147 | where 148 | nl, nr, nfresh :: Integer 149 | nl = genericLength l 150 | nr = genericLength r 151 | nfresh = nin - nl 152 | 153 | fullList bs = cryptolCat params 154 | $^ TC.tNum nl 155 | $^ TC.tNum nfresh 156 | $^ TC.tBit 157 | $$ liftBools params bs 158 | $$ TC.EVar (freshVar params) 159 | validityMismatch = cryptolNeq params 160 | $^ TC.tBit 161 | $$ (valid $$ fullList l) 162 | $$ (valid $$ fullList r) 163 | bothValid = cryptolAnd params 164 | $^ TC.tBit 165 | $$ (valid $$ fullList l) 166 | $$ (valid $$ fullList r) 167 | functionMismatch = cryptolNeq params 168 | $^ E.tValTy out 169 | $$ (unapplied $$ fullList l) 170 | $$ (unapplied $$ fullList r) 171 | abstraction = TC.EAbs (freshVar params) (TC.tSeq (TC.tNum nfresh) TC.tBit) 172 | $ cryptolOr params 173 | $^ TC.tBit 174 | $$ validityMismatch 175 | $$ ( cryptolAnd params 176 | $^ TC.tBit 177 | $$ bothValid 178 | $$ functionMismatch 179 | ) 180 | 181 | -- (!) assumes `length i <= nin` 182 | validCondition :: ExprBuilderParams -> (TC.Expr, SimpleType) -> [Bool] -> (TC.Expr, SimpleType) 183 | validCondition params (valid, SimpleType nin out) i 184 | = assert (ni <= nin) 185 | $ (abstraction, SimpleType nfresh tvBit) 186 | where 187 | ni, nfresh :: Integer 188 | ni = genericLength i 189 | nfresh = nin - ni 190 | 191 | abstraction = TC.EAbs (freshVar params) (TC.tSeq (TC.tNum nfresh) TC.tBit) 192 | $ valid $$ ( cryptolCat params 193 | $^ TC.tNum ni 194 | $^ TC.tNum nfresh 195 | $^ TC.tBit 196 | $$ liftBools params i 197 | $$ TC.EVar (freshVar params) 198 | ) 199 | 200 | validityAscription :: Integer -> P.Expr P.PName -> P.Expr P.PName 201 | validityAscription n e = P.ETyped e (P.TFun (P.TSeq (P.TNum n) P.TBit) P.TBit) 202 | 203 | infixl 1 $$, $^ 204 | ($$) :: TC.Expr -> TC.Expr -> TC.Expr 205 | ($^) :: TC.Expr -> TC.Type -> TC.Expr 206 | ($$) = TC.EApp 207 | ($^) = TC.ETApp 208 | 209 | tvBit :: E.TValue 210 | tvBit = E.TValue TC.tBit -- TODO: push this upstream 211 | 212 | liftBool :: ExprBuilderParams -> Bool -> TC.Expr 213 | liftBools :: ExprBuilderParams -> [Bool] -> TC.Expr 214 | liftBool params True = cryptolTrue params 215 | liftBool params False = cryptolFalse params 216 | liftBools params bs = TC.EList (liftBool params <$> bs) TC.tBit 217 | 218 | ident :: String -> P.PName 219 | ident = P.UnQual . packIdent 220 | 221 | evar :: String -> P.Expr P.PName 222 | evar = P.EVar . ident 223 | -------------------------------------------------------------------------------- /Cryptol/ModuleM.hs: -------------------------------------------------------------------------------- 1 | module Cryptol.ModuleM 2 | ( ModuleM 3 | , liftCmd 4 | , io 5 | , runModuleM 6 | , checkExpr 7 | , evalExpr 8 | , satProve 9 | , loadModuleByPath 10 | , loadPrelude 11 | , getEvalEnv 12 | , getPrimMap 13 | , renameInteractive 14 | , typeCheckInteractive 15 | ) where 16 | 17 | import Cryptol.ModuleSystem (ModuleCmd, initialModuleEnv) 18 | import Cryptol.ModuleSystem.Base (TCAction(TCAction, tcAction, tcLinter, tcPrims), evalExpr, exprLinter, getPrimMap, rename, typecheck) 19 | import Cryptol.ModuleSystem.Monad (ImportSource(FromModule), ModuleM, ModuleT(ModuleT), getEvalEnv, io) 20 | import Cryptol.ModuleSystem.Renamer (RenameM) 21 | import Cryptol.Symbolic (ProverCommand, ProverResult) 22 | import Cryptol.TypeCheck (tcExpr) 23 | import Cryptol.Utils.Ident (preludeName, interactiveName) 24 | import MonadLib (get, inBase, put, raise, set) 25 | import qualified Cryptol.ModuleSystem as Cmd 26 | import qualified Cryptol.ModuleSystem.Monad as Base 27 | import qualified Cryptol.Parser.AST as P 28 | import qualified Cryptol.Symbolic as Symbolic 29 | import qualified Cryptol.TypeCheck.AST as TC 30 | 31 | liftCmd :: ModuleCmd a -> ModuleM a 32 | liftCmd f = ModuleT $ do 33 | env <- get 34 | (res, ws) <- inBase (f env) 35 | put ws 36 | case res of 37 | Left err -> raise err 38 | Right (val, env') -> val <$ set env' 39 | 40 | checkExpr :: P.Expr P.PName -> ModuleM (TC.Expr, TC.Schema) 41 | checkExpr parsed = (\(_, e, s) -> (e, s)) <$> liftCmd (Cmd.checkExpr parsed) 42 | 43 | satProve :: ProverCommand -> ModuleM ProverResult 44 | satProve = liftCmd . Symbolic.satProve 45 | 46 | findModule :: P.ModName -> ModuleM FilePath 47 | findModule = liftCmd . Cmd.findModule 48 | 49 | loadModuleByPath :: FilePath -> ModuleM TC.Module 50 | loadModuleByPath = liftCmd . Cmd.loadModuleByPath 51 | 52 | runModuleM :: ModuleM a -> IO (Cmd.ModuleRes a) 53 | runModuleM act = do 54 | env <- initialModuleEnv 55 | Base.runModuleM env act 56 | 57 | loadPrelude :: ModuleM () 58 | loadPrelude = findModule preludeName >>= loadModuleByPath >> return () 59 | 60 | renameInteractive :: RenameM a -> ModuleM a 61 | renameInteractive act = do 62 | (_, namingEnv, _) <- Base.getFocusedEnv 63 | rename interactiveName namingEnv act 64 | 65 | typeCheckInteractive :: P.Expr TC.Name -> ModuleM (TC.Expr, TC.Schema) 66 | typeCheckInteractive expr = do 67 | pm <- getPrimMap 68 | (ifaceDecls, _, _) <- Base.getFocusedEnv 69 | let act = TCAction { tcAction = tcExpr, tcLinter = exprLinter, tcPrims = pm } 70 | Base.loading (FromModule interactiveName) (typecheck act expr ifaceDecls) 71 | -------------------------------------------------------------------------------- /Data/LDAG.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE Rank2Types #-} 6 | module Data.LDAG 7 | ( LDAG, layers, allLayers 8 | , Layer, nodes, allNodes 9 | , Node, nodeLabel, outgoing, dead 10 | , LayerMap 11 | , NodeMap 12 | , LayerID 13 | , NodeID 14 | , unfoldLDAGM 15 | ) where 16 | 17 | import Control.Lens (At(at), Ixed(ix), Index, IndexedTraversal, IxValue, Lens', (?=), anon, itoListOf, itraversed, makeLenses, to, use) 18 | import Control.Monad.Loops (firstM) 19 | import Control.Monad.State (MonadState, StateT, execStateT, get, gets, lift, modify, put) 20 | import Control.Monad.Supply (evalSupplyT, supply) 21 | import Data.Default (Default, def) 22 | import Data.IntMap (IntMap) 23 | import Data.Universe.Class (Finite, universeF) 24 | import Data.Universe.Instances.Eq () 25 | import Data.Universe.Instances.Ord () 26 | import Data.Universe.Instances.Read () 27 | import Data.Universe.Instances.Show () 28 | import Data.Universe.Instances.Traversable () 29 | 30 | import qualified Data.IntMap as IM 31 | 32 | type NodeID = Int 33 | type LayerID = Int 34 | type NodeMap = IntMap 35 | type LayerMap = IntMap 36 | 37 | data Node n e = Node 38 | { _nodeLabel :: n 39 | , _outgoing :: Maybe (e -> NodeID) 40 | , _dead :: Bool 41 | } deriving (Eq, Ord, Read, Show) 42 | 43 | newtype Layer n e = Layer { _nodes :: NodeMap (Node n e) } 44 | deriving (Eq, Ord, Read, Show, Default) 45 | 46 | newtype LDAG n e = LDAG { _layers :: LayerMap (Layer n e) } 47 | deriving (Eq, Ord, Read, Show, Default) 48 | 49 | makeLenses ''Node 50 | makeLenses ''Layer 51 | makeLenses ''LDAG 52 | 53 | allLayers :: IndexedTraversal LayerID (LDAG n e) (LDAG n' e') (Layer n e) (Layer n' e') 54 | allNodes :: IndexedTraversal NodeID (Layer n e) (Layer n' e') (Node n e) (Node n' e') 55 | allLayers = layers . itraversed 56 | allNodes = nodes . itraversed 57 | 58 | type instance Index (LDAG n e) = LayerID 59 | type instance Index (Layer n e) = NodeID 60 | type instance IxValue (LDAG n e) = Layer n e 61 | type instance IxValue (Layer n e) = Node n e 62 | instance Ixed (LDAG n e) where ix i = layers . ix i 63 | instance Ixed (Layer n e) where ix i = nodes . ix i 64 | instance At (LDAG n e) where at i = layers . at i 65 | instance At (Layer n e) where at i = nodes . at i 66 | 67 | atLayer :: LayerID -> Lens' (LDAG n e) (Layer n e) 68 | atLayer id = at id . anon def (null . _nodes) 69 | 70 | unfoldLDAGM 71 | :: (Monad m, Finite e, Ord e) 72 | => (n -> n -> m Bool) -> (n -> m Bool) -> (n -> Maybe (e -> n)) -> n -> m (LDAG n e) 73 | unfoldLDAGM eq dead step = flip evalSupplyT universeF . flip execStateT def . go 0 where 74 | liftedEq a b = lift (lift (eq a b)) 75 | go layerID n = do 76 | nodeMap <- gets . itoListOf $ atLayer layerID . allNodes 77 | cached <- firstM (liftedEq n . _nodeLabel . snd) nodeMap 78 | case cached of 79 | Just (nodeID, _) -> return nodeID 80 | Nothing -> do 81 | nodeID <- supply 82 | children <- traverse (traverse (go (layerID+1))) (step n) 83 | lively <- lift (lift (dead n)) 84 | atLayer layerID . at nodeID ?= Node n children lively 85 | return nodeID 86 | -------------------------------------------------------------------------------- /Data/MBP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Data.MBP 3 | ( Symbol, Output, Position, Dimensions 4 | , MBP, Step, Matrix 5 | , mbp, step, matrix 6 | , steps, outputs, branches, position, elems 7 | , HasDimensions(..) 8 | ) where 9 | 10 | import Control.Monad 11 | import Data.Aeson 12 | import Data.HashMap.Strict (HashMap) 13 | import Data.Map (Map) 14 | import Data.Maybe 15 | import Data.Monoid 16 | import Data.Text (Text) 17 | import qualified Data.HashMap.Strict as HM 18 | import qualified Data.Text as T 19 | import qualified Data.Map as M 20 | 21 | type Symbol = Text 22 | type Output = Text 23 | type Position = Text 24 | type Dimensions = (Int, Int) 25 | 26 | -- constraints: 27 | -- * steps is nonempty 28 | -- * each step's column count is the next step's row count 29 | -- * outputs has as many rows as the first step and as many columns as the last step 30 | data MBP = MBP 31 | { steps :: [Step] 32 | , outputs :: Matrix Output 33 | } deriving (Eq, Ord, Read, Show) 34 | 35 | mbp :: [Step] -> Matrix Output -> Maybe MBP 36 | mbp steps output = do 37 | outputDims <- checkDims (dims <$> steps) 38 | guard (outputDims == dims output) 39 | return (MBP steps output) 40 | where 41 | checkDims ((r,c):(r',c'):rest) = guard (c == r') >> checkDims ((r,c'):rest) 42 | checkDims short = listToMaybe short 43 | 44 | -- constraints: 45 | -- * at least one matrix 46 | -- * all matrices have the same dimensions 47 | -- * does not branch on "position" -- this is semantically stupid, and a 48 | -- wart left over from bad JSON format design 49 | data Step = Step 50 | { sDims :: Dimensions 51 | , position :: Position 52 | , branches :: Map Symbol (Matrix Integer) 53 | } deriving (Eq, Ord, Read, Show) 54 | 55 | step :: Position -> Map Symbol (Matrix Integer) -> Maybe Step 56 | step position branches = do 57 | guard ("position" `M.notMember` branches) 58 | m:ms <- return (M.elems branches) 59 | guard (all (\m' -> dims m == dims m') ms) 60 | return (Step (dims m) position branches) 61 | 62 | -- constraints: 63 | -- * rows > 0 64 | -- * cols > 0 65 | -- * map length elems = replicate rows cols 66 | data Matrix field = Matrix 67 | { mDims :: Dimensions 68 | , elems :: [[field]] 69 | } deriving (Eq, Ord, Read, Show) 70 | 71 | matrix :: [[field]] -> Maybe (Matrix field) 72 | matrix elems = do 73 | e:es <- return elems 74 | let cols = length e 75 | rows = length elems 76 | guard (all (\e' -> cols == length e') es) 77 | return (Matrix (rows, cols) elems) 78 | 79 | class HasDimensions a where dims :: a -> Dimensions 80 | instance HasDimensions Step where dims = sDims 81 | instance HasDimensions (Matrix a) where dims = mDims 82 | 83 | instance ToJSON field => ToJSON (Matrix field) where 84 | toJSON = toJSON . elems 85 | toEncoding = toEncoding . elems 86 | 87 | instance FromJSON field => FromJSON (Matrix field) where 88 | parseJSON v = do 89 | elems <- parseJSON v 90 | let rows = length elems 91 | cols:colss = map length elems 92 | if rows > 0 && all (cols==) colss 93 | then return (Matrix (rows, cols) elems) 94 | else fail "expected a non-empty rectangular array of arrays" 95 | 96 | instance ToJSON Step where 97 | toJSON (Step _ position branches) = toJSON (M.insert "position" (toJSON position) (toJSON <$> branches)) 98 | toEncoding (Step _ position branches) 99 | = pairs 100 | $ "position" .= position 101 | <> foldMap (uncurry (.=)) (M.toList branches) 102 | 103 | instance FromJSON Step where 104 | parseJSON = withObject "step" $ \o -> do 105 | position <- o .: "position" 106 | branches <- parseJSON (Object (HM.delete "position" o)) 107 | case M.elems branches of 108 | [] -> fail "each step must have at least one branch" 109 | b:bs | all (\b' -> dims b == dims b') bs -> return (Step (dims b) position branches) 110 | | otherwise -> fail "all branches in the step must have the same dimensions" 111 | 112 | instance ToJSON MBP where 113 | toJSON (MBP steps outputs) = object ["steps" .= steps, "outputs" .= outputs] 114 | toEncoding (MBP steps outputs) = pairs ("steps" .= steps <> "outputs" .= outputs) 115 | 116 | instance FromJSON MBP where 117 | parseJSON = withObject "matrix branching program" $ \o -> do 118 | steps <- o .: "steps" 119 | when (null steps) (fail "program must have at least one step") 120 | outputs <- o .: "outputs" 121 | return (MBP steps outputs) 122 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Daniel Wagner 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Daniel Wagner nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Options.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | module Options (OutputFormat(..), Options(..), getOpts) where 3 | 4 | import Control.Applicative ((<|>), many) 5 | import Control.Monad (unless) 6 | import Cryptol.Eval.Type (evalType) 7 | import Cryptol.Eval.Value (fromStr, fromSeq, isTSeq, isTBit, numTValue) 8 | import Cryptol.ModuleM (ModuleM, checkExpr, evalExpr, getEvalEnv) 9 | import Cryptol.Parser (parseExpr) 10 | import Cryptol.Symbolic (proverConfigs) 11 | import Cryptol.TypeCheck.AST (Schema(Forall)) 12 | import Cryptol.TypeCheck.Solver.InfNat (Nat'(Nat)) 13 | import Cryptol.Utils.Ident (packIdent) 14 | import Cryptol.Utils.PP (pretty) 15 | import Data.Aeson (eitherDecode) 16 | import Data.List (intercalate) 17 | import Data.Monoid ((<>)) 18 | import Data.String (fromString) 19 | import Data.Text.Encoding (encodeUtf8) 20 | import qualified Options.Applicative as Opt 21 | import qualified Cryptol.Parser.AST as P 22 | 23 | data OutputFormat = DOT | JSON | Guess deriving (Bounded, Enum, Eq, Ord, Read, Show) 24 | 25 | data Options = Options 26 | { optModules :: [FilePath] 27 | , optFunction :: P.Expr P.PName 28 | , optValid :: P.Expr P.PName 29 | , optGrouping :: Integer -> ModuleM [String] 30 | , optOutputPath :: Maybe FilePath 31 | , optOutputFormat :: OutputFormat 32 | , optSolver :: String 33 | } 34 | 35 | knownSolvers :: [String] 36 | knownSolvers = map fst proverConfigs 37 | 38 | knownSolversString = intercalate ", " knownSolvers 39 | 40 | knownSolverParser :: Opt.ReadM String 41 | knownSolverParser = do 42 | s <- Opt.str 43 | unless (s `elem` knownSolvers) (Opt.readerError $ "unknown solver " 44 | ++ s 45 | ++ "; choose from " 46 | ++ knownSolversString 47 | ) 48 | return s 49 | 50 | exprParser :: Opt.ReadM (P.Expr P.PName) 51 | exprParser = do 52 | s <- Opt.str 53 | case parseExpr (fromString s) of 54 | Left err -> Opt.readerError $ "couldn't parse cryptol expression\n" ++ pretty err 55 | Right v -> return v 56 | 57 | defExpr :: String -> Opt.Parser (P.Expr P.PName) 58 | defExpr s = case parseExpr (fromString s) of 59 | Left err -> error ("internal error: couldn't parse default expression `" ++ s ++ "`:\n" ++ pretty err) 60 | Right e -> pure e 61 | 62 | evalStrings :: P.Expr P.PName -> Integer -> ModuleM [String] 63 | evalStrings parsed _nin = do 64 | (expr, ty) <- checkExpr parsed 65 | env <- getEvalEnv 66 | assertStrings env ty 67 | map fromStr . fromSeq <$> evalExpr expr 68 | where 69 | assertStrings env schema = case schema of 70 | Forall [] _ ty -> case evalType env ty of 71 | (isTSeq -> Just (numTValue -> Nat m, isTSeq -> Just (numTValue -> Nat n, isTSeq -> Just (numTValue -> Nat 8, isTBit -> True)))) 72 | -> return () 73 | _ -> fail ("expecting list of strings (some concretization of `{m,n} [m][n][8]`), but type was\n" ++ pretty schema) 74 | _ -> fail ("expecting monomorphic type, but found\n" ++ pretty schema) 75 | 76 | stringListParser :: Opt.ReadM (Integer -> ModuleM [String]) 77 | stringListParser = do 78 | s <- Opt.str 79 | case s of 80 | "#" -> return (\nin -> return (map show [0..nin-1])) 81 | _ -> case eitherDecode . fromString $ s of 82 | Right json -> return (return (return json)) 83 | Left jsonErr -> case parseExpr . fromString $ s of 84 | Left cryptolErr -> Opt.readerError (errors jsonErr cryptolErr) 85 | Right cryptol -> return (evalStrings cryptol) 86 | where 87 | errors jsonErr cryptolErr = unlines 88 | [ "tried parsing grouping as JSON, but failed:\n" 89 | , jsonErr 90 | , "\ntried parsing grouping as cryptol, but failed:\n" 91 | , pretty cryptolErr 92 | ] 93 | 94 | optionsParser :: Opt.Parser Options 95 | optionsParser = Options 96 | <$> many (Opt.argument Opt.str (Opt.metavar "FILE ...")) 97 | <*> (Opt.option exprParser ( Opt.short 'e' 98 | <> Opt.metavar "EXPR" 99 | <> Opt.help "a cryptol expression to partially evaluate (default `main`)" 100 | ) 101 | <|> defExpr "main" 102 | ) 103 | <*> (Opt.option exprParser ( Opt.short 'v' 104 | <> Opt.metavar "EXPR" 105 | <> Opt.help "a cryptol expression marking inputs as valid (default `valid`)" 106 | ) 107 | <|> defExpr "valid" 108 | ) 109 | <*> (Opt.option stringListParser ( Opt.short 'g' 110 | <> Opt.metavar "EXPR" 111 | <> Opt.help "a JSON or cryptol expression naming the input positions, or '#' for sequential names (default `grouping`)" 112 | ) 113 | <|> (evalStrings <$> defExpr "grouping") 114 | ) 115 | <*> Opt.optional (Opt.strOption ( Opt.short 'o' 116 | <> Opt.metavar "FILE" 117 | <> Opt.help "output file (default stdout)" 118 | ) 119 | ) 120 | <*> (Opt.option Opt.auto ( Opt.short 'f' 121 | <> Opt.metavar "FORMAT" 122 | <> Opt.help ( "output format: " 123 | ++ intercalate ", " (map show [minBound .. maxBound :: OutputFormat]) 124 | ++ " (default Guess)" 125 | ) 126 | ) 127 | <|> pure Guess 128 | ) 129 | <*> (Opt.option knownSolverParser ( Opt.short 's' 130 | <> Opt.metavar "SOLVER" 131 | <> Opt.help ( "which SMT solver to use: " 132 | ++ knownSolversString 133 | ++ " (default any)" 134 | ) 135 | ) 136 | <|> pure "any" 137 | ) 138 | 139 | optionsInfo :: Opt.ParserInfo Options 140 | optionsInfo = Opt.info (Opt.helper <*> optionsParser) 141 | ( Opt.fullDesc 142 | <> Opt.progDesc "Produce a finite state machine that emulates EXPR, inspecting one input bit at a time, using SOLVER to check equality of states. The type of the main function EXPR to be translated should be monomorphic, and unify with `{a} (Cmp a) => [n] -> a`." 143 | ) 144 | 145 | getOpts :: IO Options 146 | getOpts = Opt.execParser optionsInfo 147 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Tutorial: comparisons 2 | 3 | The `cryfsm` tool can be used to convert certain expressions of the Cryptol 4 | language to layered finite state machines, which are suitable for use in matrix 5 | branching program-based obfuscation tools. As a running example, we will take 6 | the program which compares two numbers, outputting one of the strings `"<"`, 7 | `"="`, or `">"`. 8 | 9 | ## Creating `comparison.cry` 10 | 11 | The cryptol expression which computes a single comparison looks like this: 12 | 13 | compare x y = if x < y 14 | then "<" 15 | else if x == y 16 | then "=" 17 | else ">" 18 | 19 | Here and below, we will use *italics* to mark text explaining Cryptol syntax 20 | and standard library functions -- feel free to skip this text if you are 21 | already familiar with Cryptol! 22 | 23 | *As in many other functional languages, function application is juxtaposition, 24 | so that `f x` means "apply function `f` to argument `x`". The above snippet 25 | defines a new function of two arguments.* 26 | 27 | The `cryfsm` tools works only on bit strings, so we will need to tell it how to 28 | parse a string of bits into two numbers. For simplicity, we will assume that 29 | the bits of our numbers come in interleaved, so that the two numbers `abcd` and 30 | `wxyz` would be represented by the bit string `awbxcydz`. We will also 31 | specialize things to three-bit numbers for the moment. So our top-level 32 | function will de-interleave the strings, then hand off the result to `compare`: 33 | 34 | main : [6] -> String 1 35 | main input = compare x y where 36 | [x, y] = transpose (split input) 37 | 38 | *The first line is a type declaration saying that `main` is a function that 39 | takes bitstrings of length 6 (`[6]`) to bytestrings of length 1 (`String 1`). 40 | The `split` operation groups together adjacent pairs of bits, and `transpose` 41 | is a matrix-transpose operation; together, these two operations put every 42 | even-indexed bit into `x` and every odd-indexed bit into `y`.* 43 | 44 | We are almost ready to invoke `cryfsm`; we need two other small pieces which we 45 | will discuss in detail a bit later. For the moment, simply add the above code 46 | and the following two lines to a file named `comparison.cry`: 47 | 48 | valid _ = True 49 | grouping = ["l", "r", "l", "r", "l", "r"] 50 | 51 | *The `_` in `valid _ = True` is called a wildcard. It is valid in patterns 52 | (that is, to the left of an `=`), but not in expressions, so it can be used to 53 | declare that the corresponding function argument will not be used.* 54 | 55 | ## Visualizing the layered FSM with dot 56 | 57 | We can now run the following commands to visualize a finite state machine that 58 | computes the `main` function: 59 | 60 | cryfsm comparison.cry -o comparison.dot 61 | dot -Tgtk comparison.dot 62 | 63 | ![Our first layered finite state machine](images/comparison-vanilla.png) 64 | 65 | The node at the top of the diagram with the empty label is the start node for 66 | our state machine. Each node is labeled with the prefix of a bitstring that 67 | leads to that node, and each edge is labeled with a bit as usual for finite 68 | state machines. (For example, following the edges labeled `0`, `0`, `1`, `0` 69 | leads us from the start state to the state labeled `0010`.) Prefixes which 70 | "behave the same" are coalesced into a single state. For example, on the second 71 | layer here, we can see states labeled `00`, `01`, and `10`, but none labeled 72 | `11`. Any bitstring that starts with `00` corresponds to comparing two numbers 73 | whose first bit is both `0`; the remainder of the numbers will decide the 74 | outcome of the comparison. Likewise, the bitstrings that start with `11` 75 | correspond to comparing two numbers whose first bit is both `1`; again, the 76 | remainder of the numbers will decide the outcome of the comparison in exactly 77 | the same way. Using this reasoning, we can give rough intuitions for the three 78 | states in this layer: 79 | 80 | * `00`: the two numbers are equal so far, hold off judgment 81 | * `01`: we already know the first number is smaller than the second one 82 | * `10`: we already know the second number is smaller than the first one 83 | 84 | It is often possible to give such intuitions for particular states. 85 | 86 | In cases like this where many bitstring prefixes have been coalesced into a 87 | single state, `cryfsm` will arbitrarily choose a representative prefix to use 88 | as the state label. 89 | 90 | In the last layer, states are labeled instead by simply evaluating `main` on 91 | one of the chosen representative prefixes (which are now a complete input). 92 | 93 | We will come back to the meaning of the rounded rectangles surrounding 94 | subgraphs. 95 | 96 | ## Machine-readable MBP templates 97 | 98 | Instead of printing the state machine as a dot-style graph, we can ask for a 99 | machine-readable representation of matrix branching programs by executing the 100 | following command: 101 | 102 | cryfsm comparison.cry -o comparison.json 103 | 104 | With a bit of formatting, and some matrices elided for brevity, 105 | `comparison.json` looks like this: 106 | 107 | {"steps": 108 | [{"0":[[1,0]] 109 | ,"1":[[0,1]] 110 | ,"position":"l" 111 | } 112 | ,{"0":[[1,0,0] 113 | ,[0,0,1] 114 | ] 115 | ,"1":[[0,1,0] 116 | ,[1,0,0] 117 | ] 118 | ,"position":"r" 119 | } 120 | ,{"0":...,"1":...,"position":"l"} 121 | ,{"0":...,"1":...,"position":"r"} 122 | ,{"0":...,"1":...,"position":"l"} 123 | ,{"0":[[1,0,0] 124 | ,[0,0,1] 125 | ,[0,1,0] 126 | ,[0,0,1] 127 | ] 128 | ,"1":[[0,1,0] 129 | ,[1,0,0] 130 | ,[0,1,0] 131 | ,[0,0,1] 132 | ] 133 | ,"position":"r" 134 | } 135 | ] 136 | ,"outputs":[["\"=\"","\"<\"","\">\""]] 137 | } 138 | 139 | The top-level object has two fields: `steps` gives a way to construct a matrix 140 | branching program for a particular input, and `outputs` tells how to interpret 141 | the result of executing the resulting matrix branching program. We discuss each 142 | in turn. 143 | 144 | The `steps` field contains a list of six objects -- one for each bit of input 145 | to our original `main` function. Each object has a field named `position`, 146 | which we will ignore for now, and one field per possible input symbol 147 | containing a matrix. We can construct a matrix branching program for a 148 | particular input by choosing the appropriate matrix from each step; for 149 | example, if we wanted to construct a matrix branching program that asks how 150 | `110` and `001` compare, we would use the input bitstring `101001` to choose 151 | the matrices: 152 | 153 | [[0,1]] 154 | 155 | [[1,0,0] 156 | ,[0,0,1] 157 | ] 158 | 159 | [[0,1,0,0] 160 | ,[0,0,1,0] 161 | ,[0,0,0,1] 162 | ] 163 | 164 | [[1,0,0] 165 | ,[0,0,1] 166 | ,[0,1,0] 167 | ,[0,0,1] 168 | ] 169 | 170 | [[1,0,0,0] 171 | ,[0,0,1,0] 172 | ,[0,0,0,1] 173 | ] 174 | 175 | [[0,1,0] 176 | ,[1,0,0] 177 | ,[0,1,0] 178 | ,[0,0,1] 179 | ] 180 | 181 | (Three of these matrices come from the elided portion of `comparison.json`.) 182 | Multiplying these matrices produces the matrix 183 | 184 | [[0,0,1]] 185 | 186 | which, on its own, doesn't necessarily hold much meaning to us. 187 | 188 | The `outputs` field tells us how to interpret this result: it gives us a way to 189 | tie positions in the result matrix to outputs of the original `main` function. 190 | Since we have a `1` in row 1, column 3 of the result matrix, we look in row 1, 191 | column 3 of the `outputs` matrix to find `"\">\""`, which means the result 192 | matrix `[[0,0,1]]` represents the cryptol value `">"`. 193 | 194 | ## Optimization: bit swizzling 195 | 196 | For some applications, it is useful to process bits in a different order than 197 | simple interleaving. For example, when computing `L < R`, the order `L0 R0 L1 198 | R1 L2 R2 L3 R3 ...` requires as many matrices as there are inputs; but if we 199 | swap every other pair of bits to the order `(L0 R0) (R1 L1) (L2 R2) (R3 L3) 200 | ...` then we can use roughly half as many matrices. This can be a significant 201 | performance win. 202 | 203 | To accomodate this use case, `cryfsm` allows grouping of input bits. The 204 | `grouping` declaration in our running example gives us control of this 205 | grouping. Recall that it was defined this way: 206 | 207 | grouping = ["l", "r", "l", "r", "l", "r", "l", "r"] 208 | 209 | The meaning of the `grouping` definition is this: each argument to the function 210 | we want to compute is given a name. The `grouping` is a list of these names, 211 | one for each input bit, telling which input the associated bit is determined 212 | by. When multiple adjacent bits are determined by the same input, `cryfsm` will 213 | draw a subgraph grouping around the associated layers of the state machine and 214 | will multiply the associated matrices in the branching program template. 215 | 216 | Here's how we could write a modified comparison that uses the more advanced bit 217 | ordering. 218 | 219 | main : [6] -> String 1 220 | main input = compare x y where 221 | [x, y] = transpose (reverseEveryOther (split input)) 222 | valid _ = True 223 | grouping = ["l", "r", "r", "l", "l", "r"] 224 | 225 | reverseEveryOther : {a,b,c} fin b => [a][b]c -> [a][b]c 226 | reverseEveryOther xs = [f x | f <- cycle [\x -> x, reverse] | x <- xs] 227 | cycle xs = xs # cycle xs 228 | compare x y = if x < y 229 | then "<" 230 | else if x == y 231 | then "=" 232 | else ">" 233 | 234 | The main changes here are that we have added a call to `reverseEveryOther` into 235 | the "parsing" step of `main`, and the `grouping` constant has been updated to 236 | reflect the new bit ordering. The `compare` function remains unchanged. 237 | 238 | *The syntax `[e | x <- ex | y <- ey]` is a **list comprehension**. Using `@` 239 | for list indexing, and naming this comprehension `v`, we can describe the 240 | behavior of the list comprehension like this: the value `v@i` is equal to `e` 241 | where we have replaced any occurrences of `x` in `e` with `ex@i`, and likewise 242 | replaced `y` with `ey@i`. So the list comprehension runs down the two lists 243 | `ex` and `ey` in parallel, binding the values to `x` and `y` and then computing 244 | `e`. The resulting list is as long as the shorter of the two lists `ex` and 245 | `ey`.* 246 | 247 | *The `#` function concatenates two lists. So `cycle xs` is an infinite list 248 | obtained by repeating the input list `xs` over and over.* 249 | 250 | *The type signature for `reverseEveryOther` is quite involved compared to other 251 | signatures we've seen so far. List types are represented by their length and 252 | contained type, so that `[8]Bit` is a list of length `8` containing `Bit`s, and 253 | `[a][b]c` is a list of length `a` containing lists of length `b` containing 254 | `c`s. The braces in the type indicate that it is polymorphic over lengths `a` 255 | and `b` and contained types `c`. The fat arrow `=>` separates the type from 256 | constraints that instantiations of the polymorphic type variables must satisfy; 257 | `fin n` says that `n` cannot be the distinguished infinite number `inf` -- that 258 | is, that the contained lists must end. This constraint comes from the call to 259 | `reverse`.* 260 | 261 | If we run `cryfsm` on the above file to produce a matrix branching program 262 | template, we see something interesting: instead of six steps as before, there 263 | are now only four steps. The price we pay is that the middle two steps are now 264 | associated with twice as many matrices; but if the reduced number of steps also 265 | reduces the multilinearity level needed, this can still be a win. 266 | 267 | {"steps":[{"0":[[1,0]] 268 | ,"1":[[0,1]] 269 | ,"position":"l" 270 | } 271 | ,{"00":[[1,0,0,0],[0,0,0,1]] 272 | ,"01":[[0,1,0,0],[0,0,0,1]] 273 | ,"11":[[0,0,1,0],[0,1,0,0]] 274 | ,"10":[[0,0,1,0],[1,0,0,0]] 275 | ,"position":"r" 276 | } 277 | ,{"00":[[1,0,0,0],[0,0,0,1],[0,0,0,1],[0,0,1,0]] 278 | ,"01":[[0,1,0,0],[0,0,0,1],[0,0,0,1],[0,0,1,0]] 279 | ,"11":[[0,0,1,0],[0,1,0,0],[0,0,0,1],[0,0,1,0]] 280 | ,"10":[[0,0,1,0],[1,0,0,0],[0,0,0,1],[0,0,1,0]] 281 | ,"position":"l" 282 | } 283 | ,{"0":[[1,0,0],[0,0,1],[0,0,1],[0,1,0]] 284 | ,"1":[[0,1,0],[1,0,0],[0,0,1],[0,1,0]] 285 | ,"position":"r" 286 | } 287 | ] 288 | ,"outputs":[["\"=\"","\"<\"","\">\""]] 289 | } 290 | 291 | ## Base-3 comparisons 292 | 293 | In some applications one may wish to use an alphabet in their state machine 294 | which is not a clean power of two, and so can't be cleanly represented using 295 | only the tools so far. To continue our running example, we might imagine 296 | wanting to represent our numbers in base 3 rather than base 2. (Again, in our 297 | case the tradeoff will be increasing the number of matrices at each step but 298 | potentially decreasing the total number of steps and multilinearity parameter 299 | at the same time.) The `cryfsm` tool offers a way to mark certain input strings 300 | as invalid for this purpose. 301 | 302 | To simplify the exposition, we will return to the unoptimized bit ordering (so 303 | just interleaving digits of the numbers we want to compare), and drop from 304 | comparing three-digit numbers to comparing two-digit numbers. 305 | 306 | Our encoding of the input numbers will be as follows: if we want to compare the 307 | two digits `ab` to the two digits `xy`, we will first use two bits each to 308 | represent the digits `a`, `b`, `x`, and `y`, then send them to our top-level 309 | function in the order `a0 a1 x0 x1 b0 b1 y0 y1`. Our "parsing" step will look 310 | very similar, but we must now `split` twice: once to group together bits that 311 | represent a single digit, and once to group together digits. 312 | 313 | main : [8] -> String 1 314 | main in = compare x y where 315 | [x, y] = transpose (split (split `{each=2} in)) 316 | 317 | *The syntax ```split `{each=2}``` specializes the `split` function to produce 318 | chunks of length `2`.* 319 | 320 | However, there are now some invalid inputs, namely, any which include a `3` 321 | digit somewhere. We can check for this problem this way: 322 | 323 | valid in = [x <= 2 | x <- split `{each=2} in] == ~zero 324 | 325 | *The `~` operator is bitwise negation, and `zero` is the all-zero object, so 326 | the `== ~zero` comparison checks that each element of the list is `True`.* 327 | 328 | We must also slightly modify `grouping` to reflect the fact that two bits at a 329 | time are determined by each input, thus: 330 | 331 | grouping = ["l", "l", "r", "r", "l", "l", "r", "r"] 332 | 333 | As always, the `compare` function is unchanged. When we visualize the state 334 | machine, we will see some states marked with a dotted border to signify that 335 | they are unreachable by valid inputs: 336 | 337 | ![A layered finite state machine with invalid states](images/comparison-base3.png) 338 | 339 | Paths that involve invalid states are omitted when emitting program templates, 340 | so the invalid bit sequence "11" does not appear as a key in any of the steps: 341 | 342 | {"steps":[{"00":[[1,0,0]] 343 | ,"01":[[0,1,0]] 344 | ,"10":[[0,0,1]] 345 | ,"position":"l" 346 | } 347 | ,{"00":[[1,0,0],[0,0,1],[0,0,1]] 348 | ,"01":[[0,1,0],[1,0,0],[0,0,1]] 349 | ,"10":[[0,1,0],[0,1,0],[1,0,0]] 350 | ,"position":"r" 351 | } 352 | ,{"00":[[1,0,0,0,0],[0,0,0,1,0],[0,0,0,0,1]] 353 | ,"01":[[0,1,0,0,0],[0,0,0,1,0],[0,0,0,0,1]] 354 | ,"10":[[0,0,1,0,0],[0,0,0,1,0],[0,0,0,0,1]] 355 | ,"position":"l" 356 | } 357 | ,{"00":[[1,0,0],[0,0,1],[0,0,1],[0,1,0],[0,0,1]] 358 | ,"01":[[0,1,0],[1,0,0],[0,0,1],[0,1,0],[0,0,1]] 359 | ,"10":[[0,1,0],[0,1,0],[1,0,0],[0,1,0],[0,0,1]] 360 | ,"position":"r" 361 | } 362 | ] 363 | ,"outputs":[["\"=\"","\"<\"","\">\""]] 364 | } 365 | 366 | # Flag reference 367 | 368 | You may pass any number (including 0) of cryptol modules to `cryfsm`. It also 369 | recognizes the following flags: 370 | 371 | `-h` or `--help`: show a brief help text 372 | 373 | `-e EXPR`: Specify which function to generate a state machine for. The type of 374 | the associated `EXPR` should be `[n] -> a` for some finite number `n` and 375 | comparable type `a` (i.e. `(fin n, Cmp a)` should hold). Defaults to `main`. 376 | 377 | `-v EXPR`: Specify which inputs are valid. The type of the associated `EXPR` 378 | should be `[n] -> Bit` for the same `n` as in the type of the expression given 379 | to `-e`. It is recommended that this function be kept relatively simple and 380 | local; complicated expressions here may result in many spurious states being 381 | generated to keep track of whether we must transition to an invalid state. 382 | Defaults to `valid`. 383 | 384 | `-g EXPR`: Specify how input bits should be grouped when producing the program 385 | template. The `EXPR` can be either a cryptol expression or a JSON object; in 386 | either case, it should be a list of strings. Any adjacent elements with the 387 | same string are grouped together. To ease usage with obfuscation tasks, you may 388 | also pass `-g #` to get a grouping which contains string representations of the 389 | numbers `0` to `n-1`, where `n` is as in the type of the expression given to 390 | `-e`. Defaults to `grouping`. 391 | 392 | `-o FILE`: Choose a file to output to. If not specified, results are printed 393 | to stdout. 394 | 395 | `-f FORMAT`: Choose whether to output as a layered finite state machine 396 | visualization or as a matrix branching program template. The `FORMAT` can be 397 | one of `DOT` for visualizations, `JSON` for templates, or `Guess`. When you 398 | choose `Guess`, it will act as though you had specified `DOT` unless the 399 | filename given to `-o` ends in `.json`. Defaults to `Guess`. 400 | 401 | `-s SOLVER`: Choose an SMT solver to use for state machine minimization. 402 | Available choices depend on your build; see `--help` for a complete list. 403 | Defaults to `any`, which will use any solver it can find the installation 404 | location for. 405 | 406 | # Output reference 407 | 408 | ## DOT 409 | 410 | The DOT output produces a relatively standard finite state machine diagram with 411 | just a few features worth calling out. 412 | 413 | All state machines are layered, meaning that each state can be reached only by 414 | a single, fixed number of symbols from the start state. The consequence of this 415 | is that most states can be ignored when translating a given layer (collection 416 | of edges at the same "depth") to matrix form. 417 | 418 | Each state is an equivalence class of binary prefixes of a valid input. A 419 | prefix is considered invalid if all continuations are. Prefixes are considered 420 | equivalent if for every appropriately sized suffix, either one of two 421 | conditions holds: 422 | 423 | 1. Both full strings are invalid, or 424 | 2. Both full strings are valid and the cryptol expression you are converting 425 | has the same result for both full strings. 426 | 427 | States in the last layer are labeled by cryptol values as output by the 428 | function being compiled. All other states are labeled by an arbitrary 429 | representative of their equivalence class. 430 | 431 | The value specified for grouping of input bits is used to group together layers 432 | in subgraphs. These subgraphs are labeled with the position name from the 433 | grouping. 434 | 435 | ## JSON 436 | 437 | The top level object contains two keys, `steps` and `outputs`. To run a program 438 | represented by this JSON, one would choose a single matrix from each step, 439 | multiply them together, and use the outputs to connect this result to the 440 | results of the original expression being converted. 441 | 442 | The `steps` field contains a list of steps. Each step is an object with one 443 | field named `position`, which contains a free-form string determined by the 444 | grouping expression, and some number of other fields containing a matrix (as a 445 | list of lists of numbers that are always `0` or `1`). All matrices in a single 446 | step have the same size, and the sizes are compatible from step-to-step (the 447 | number of columns in step `i` is the number of rows in step `i+1`). The matrix 448 | fields have bitstring keys that can be used to select the appropriate matrix 449 | during evaluation. (Concatenating the keys chosen from each step should give 450 | the input you want to evaluate the function on.) The matrices in the first step 451 | will always have exactly one row. 452 | 453 | If you choose one matrix from each step and compute their product, you will get 454 | a matrix with exactly one `1` in it. Without knowing anything more, this would 455 | not tell you much about the meaning of the evaluation; the `outputs` field 456 | describes the connection between which entry of the result matrix is `1` and 457 | what the original function outputs. Specifically, if there is a `1` in row `r` 458 | and column `c` of the result matrix, then the string in row `r` and column `c` 459 | of `outputs` gives the cryptol value output by the original function. 460 | 461 | [//]: # (TODO: too much English, use formatting to make this more vgrep-able) 462 | 463 | # Installation 464 | 465 | Once you have installed cryptol itself, installing `cryfsm` should be as simple 466 | as typing `cabal install` from within this repository. By default, this places 467 | executables in `~/.cabal/bin`. See [`cryfsm.cabal`](cryfsm.cabal) for a listing 468 | of compatible cryptol versions. There are detailed instructions for building 469 | cryptol from source [in the cryptol 470 | README](https://github.com/GaloisInc/cryptol/#building-cryptol-from-source). 471 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cryfsm.cabal: -------------------------------------------------------------------------------- 1 | -- Initial cryfsm.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: cryfsm 5 | version: 0.0 6 | synopsis: convert cryptol expressions to finite state machines 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Daniel Wagner 11 | maintainer: dmwit@galois.com 12 | -- copyright: 13 | category: Language 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | executable cryfsm 19 | main-is: cryfsm.hs 20 | other-modules: Convert.LDAG.DOT 21 | Convert.LDAG.JSON 22 | Convert.Misc.String 23 | Cryptol.FSM 24 | Cryptol.ModuleM 25 | Data.LDAG 26 | Options 27 | other-extensions: GeneralizedNewtypeDeriving, 28 | FlexibleContexts, 29 | ViewPatterns 30 | build-depends: aeson >=0.10 && <0.11, 31 | base >=4.8 && <4.9, 32 | containers >=0.5 && <0.6, 33 | cryptol >=2.3 && <2.4, 34 | data-default >=0.5 && <0.6, 35 | fgl >=5.5 && <5.6, 36 | filepath >=1.4 && <1.5, 37 | graphviz >=2999.18 && <2999.19, 38 | lens >=4 && <5, 39 | monadLib >=3.7 && <3.8, 40 | monad-loops >=0.4 && <0.5, 41 | monad-supply >=0.6 && <0.7, 42 | mtl >=2.2 && <2.3, 43 | optparse-applicative >=0.12 && <0.13, 44 | text >=1.2 && <1.3, 45 | transformers >=0.4 && <0.5, 46 | universe-base >=1.0 && <1.1, 47 | universe-reverse-instances >=1.0 && <1.1 48 | -- hs-source-dirs: 49 | default-language: Haskell2010 50 | 51 | executable numfsm 52 | main-is: numfsm.hs 53 | other-modules: Data.MBP 54 | build-depends: aeson >=0.10 && <0.11, 55 | base >=4.8 && <4.9, 56 | containers >=0.5 && <0.6, 57 | bytestring >=0.10 && <0.11, 58 | mtl >=2.2 && <2.3, 59 | optparse-applicative >=0.12 && <0.13, 60 | text >=1.2 && <1.3, 61 | total-map >=0.0.6 && <0.1, 62 | unordered-containers >=0.2 && <0.3, 63 | vector >=0.11 && <0.12 64 | 65 | executable fsmevade 66 | main-is: fsmevade.hs 67 | other-modules: Data.MBP 68 | build-depends: aeson >=0.10 && <0.11, 69 | base >=4.8 && <4.9, 70 | containers >=0.5 && <0.6, 71 | bytestring >=0.10 && <0.11, 72 | optparse-applicative >=0.12 && <0.13, 73 | text >=1.2 && <1.3, 74 | unordered-containers >=0.2 && <0.3 75 | -------------------------------------------------------------------------------- /cryfsm.hs: -------------------------------------------------------------------------------- 1 | import Control.Lens (traverseOf) 2 | import Control.Monad.State (evalStateT, lift, unless, when) 3 | import Cryptol.Eval.Value (isTBit) 4 | import Cryptol.FSM 5 | import Cryptol.ModuleM 6 | import Cryptol.Utils.PP (pretty) 7 | import Data.LDAG 8 | import Options 9 | import System.Exit (ExitCode(ExitFailure), exitWith) 10 | import System.FilePath (takeExtension) 11 | import System.IO (hPutStrLn, stderr) 12 | 13 | import qualified Convert.LDAG.DOT as DOT 14 | import qualified Convert.LDAG.JSON as JSON 15 | import qualified Data.Text.Lazy.IO as T 16 | 17 | main = do 18 | opts <- getOpts 19 | let howToPrint = case optOutputPath opts of 20 | Just file -> T.writeFile file 21 | _ -> T.putStrLn 22 | outputFormat = case optOutputFormat opts of 23 | Guess -> case takeExtension <$> optOutputPath opts of 24 | Just ".json" -> JSON 25 | _ -> DOT 26 | known -> known 27 | 28 | res <- runModuleM $ do 29 | when (null (optModules opts)) loadPrelude 30 | mapM_ loadModuleByPath (optModules opts) 31 | function <- checkExprSimpleType $ optFunction opts 32 | let nin = inputBits (snd function) 33 | valid <- checkExprSimpleType $ validityAscription nin (optValid opts) 34 | grouping <- optGrouping opts nin 35 | params <- getExprBuilderParams 36 | ldag_ <- unfoldLDAGM (checkEquality params (optSolver opts) function valid) 37 | (checkDead params (optSolver opts) valid) 38 | (step nin) 39 | [] 40 | ldag <- traverseOf allLabels (evalSaturated params nin (fst function)) ldag_ 41 | 42 | io . howToPrint $ case outputFormat of 43 | DOT -> DOT.convert ldag grouping 44 | JSON -> JSON.convert ldag grouping 45 | 46 | case res of 47 | (Left err, _ ) -> hPutStrLn stderr (pretty err) >> exitWith (ExitFailure 1) 48 | (_ , ws) -> mapM_ (putStrLn . pretty) ws 49 | 50 | where 51 | allLabels = allLayers . allNodes . nodeLabel 52 | -------------------------------------------------------------------------------- /examples/hamming-obf.cry: -------------------------------------------------------------------------------- 1 | main in = distance 0b11110000 in < 3 2 | valid _ = True 3 | grouping = ["1", "2", "3", "4", "5", "6", "7", "8"] 4 | 5 | distance : {a,b} (fin a, a >= 1, Cmp b) => [a]b -> [a]b -> [width a] 6 | distance xs ys = popcount [x != y | x <- xs | y <- ys] 7 | 8 | popcount : {a} (fin a, a >= 1) => [a] -> [width a] 9 | popcount xs = sums!0 where 10 | sums = [0] # [sum + (0 # [x]) | x <- xs | sum <- sums] 11 | -------------------------------------------------------------------------------- /examples/hamming.cry: -------------------------------------------------------------------------------- 1 | import util 2 | 3 | main in = distance (unswizzle `{base=3, len=5} in) < 3 4 | valid in = constantBase `{base=3} (unswizzle `{base=3, len=5} in) 5 | grouping = swizzledGrouping `{base=3, nin=2} 6 | 7 | distance : {a,b} (fin a, a >= 1, Cmp b) => [2][a]b -> [width a] 8 | distance [xs, ys] = popcount [x != y | x <- xs | y <- ys] 9 | 10 | popcount : {a} (fin a, a >= 1) => [a] -> [width a] 11 | popcount xs = sums!0 where 12 | sums = [0] # [sum + (0 # [x]) | x <- xs | sum <- sums] 13 | -------------------------------------------------------------------------------- /examples/hamming3.cry: -------------------------------------------------------------------------------- 1 | import util 2 | 3 | main in = maxDistance (unswizzle `{base=2, len=5, nin=3} in) < 2 4 | valid in = constantBase `{base=2} (unswizzle `{base=2, len=3} in) 5 | grouping = swizzledGrouping `{base=2, nin=3} 6 | 7 | maxDistance : {a,b,nin} (fin a, a >= 1, Cmp b, fin nin, nin >= 1) => [nin][a]b -> [width a] 8 | maxDistance xs = maximum [distance x y | x <- xs , y <- xs] 9 | 10 | maximum : {a,b} (fin a, a >= 1, Cmp b) => [a]b -> b 11 | maximum xs = maxs!0 where 12 | maxs = take `{1} xs # [max x y | x <- drop `{1} xs | y <- maxs] 13 | 14 | distance : {a,b} (fin a, a >= 1, Cmp b) => [a]b -> [a]b -> [width a] 15 | distance xs ys = popcount [x != y | x <- xs | y <- ys] 16 | 17 | popcount : {a} (fin a, a >= 1) => [a] -> [width a] 18 | popcount xs = sums!0 where 19 | sums = [0] # [sum + (0 # [x]) | x <- xs | sum <- sums] 20 | -------------------------------------------------------------------------------- /examples/ore-clt.cry: -------------------------------------------------------------------------------- 1 | import util 2 | 3 | main in = compare (unswizzle `{base=6, len=16} in) 4 | valid in = constantBase `{base=6} (unswizzle `{base=6, len=16} in) 5 | grouping = swizzledGrouping `{base=6, nin=2} 6 | 7 | compare : {a} Cmp a => [2]a -> String 1 8 | compare [x,y] = if x < y then "<" else if x == y then "=" else ">" 9 | -------------------------------------------------------------------------------- /examples/ore-gghlite.cry: -------------------------------------------------------------------------------- 1 | import util 2 | 3 | main in = compare (unswizzle `{base=5, len=18} in) 4 | valid in = constantBase `{base=5} (unswizzle `{base=5, len=18} in) 5 | grouping = swizzledGrouping `{base=5, nin=2} 6 | 7 | compare : {a} Cmp a => [2]a -> String 1 8 | compare [x,y] = if x < y then "<" else if x == y then "=" else ">" 9 | -------------------------------------------------------------------------------- /examples/ore.cry: -------------------------------------------------------------------------------- 1 | import util 2 | 3 | main in = compare (unswizzle `{base=4, len=17} in) 4 | valid in = constantBase `{base=4} (unswizzle `{base=4, len=17} in) 5 | grouping = swizzledGrouping `{base=4, nin=2} 6 | 7 | compare : {a} Cmp a => [2]a -> String 1 8 | compare [x,y] = if x < y then "<" else if x == y then "=" else ">" 9 | -------------------------------------------------------------------------------- /examples/util.cry: -------------------------------------------------------------------------------- 1 | module util where 2 | 3 | type MaxPosn = 26 4 | 5 | constantBase : {base, len, nin} (fin base, fin len, fin nin, base >= 1) 6 | => [nin][len][width (base-1)] -> Bit 7 | constantBase in = [x <= `(base-1) | xs <- in, x <- xs] == ~zero 8 | 9 | adjacentConstantBase : {base, n} (fin n, fin base, base >= 1) 10 | => [n * width (base - 1)] -> Bit 11 | adjacentConstantBase in = [x <= `(base-1) | x <- split `{parts=n, each=width (base - 1)} in] == ~zero 12 | 13 | positionNames : [MaxPosn](String 1) 14 | positionNames = ["a","b","c","d","e","f","g","h","i","j","k","l","m","n","o","p","q","r","s","t","u","v","w","x","y","z"] 15 | 16 | interleavedGrouping : {base, nin} (fin base, base >= 2, 1 <= nin, nin <= MaxPosn) 17 | => [nin * width (base-1)](String 1) 18 | interleavedGrouping = 19 | [ positionNames @ i 20 | | i <- [0 .. nin-1] 21 | , _ <- [1 .. width (base-1)] 22 | ] 23 | 24 | swizzledGrouping : {base, nin} (fin base, base >= 2, 1 <= nin, nin <= MaxPosn) 25 | => [2 * nin * width (base-1)](String 1) 26 | swizzledGrouping = posns # reverse posns where 27 | posns = interleavedGrouping `{base, nin} 28 | 29 | uninterleave : {base, len, nin} (fin base, fin len, fin nin, base >= 1) 30 | => [nin * len * width (base-1)] -> [nin][len][width (base-1)] 31 | uninterleave bits = transpose (split (split bits)) 32 | 33 | unswizzle : {base, len, nin} (fin base, fin len, fin nin, base >= 1) 34 | => [nin * len * width (base-1)] -> [nin][len][width (base-1)] 35 | unswizzle bits = transpose (reverseEveryOther (split (split bits))) 36 | 37 | reverseEveryOther : {a,b,c} fin b => [a][b]c -> [a][b]c 38 | reverseEveryOther xs = [f x | f <- cycle [\x -> x, reverse] | x <- xs] 39 | 40 | cycle : {a,b} (fin a) => [a]b -> [inf]b 41 | cycle xs = xs # cycle xs 42 | -------------------------------------------------------------------------------- /examples/xor.cry: -------------------------------------------------------------------------------- 1 | module xor where 2 | 3 | import util 4 | 5 | main in = xorZero (unswizzle `{base=4, nin=3, len=8} in) 6 | valid in = constantBase `{base=4} (unswizzle `{base=4, nin=3, len=8} in) 7 | grouping = swizzledGrouping `{base=4, nin=3} 8 | 9 | xorZero vs = xors!0 == zero where 10 | xors = [zero] # [acc ^ v | acc <- xors | v <- vs] 11 | -------------------------------------------------------------------------------- /fsmevade.hs: -------------------------------------------------------------------------------- 1 | import Data.Aeson (eitherDecode, encode) 2 | import Data.List (findIndex, intercalate) 3 | import Data.MBP (HasDimensions(dims), MBP, branches, elems, matrix, mbp, outputs, position, step, steps) 4 | import Data.ByteString.Lazy (ByteString) 5 | import Data.Text (Text) 6 | import Data.Monoid ((<>)) 7 | import System.Exit (die) 8 | import qualified Data.ByteString.Lazy as BS 9 | import qualified Data.Text as T 10 | import qualified Options.Applicative as Opt 11 | 12 | data Options = Options 13 | { source :: Maybe FilePath 14 | , target :: Maybe FilePath 15 | , selection :: Text 16 | } 17 | deriving (Eq, Ord, Read, Show) 18 | 19 | optionsParser :: Opt.Parser Options 20 | optionsParser = Options 21 | <$> Opt.optional (Opt.strOption ( Opt.short 'i' 22 | <> Opt.metavar "FILE" 23 | <> Opt.help "input file (default stdin)" 24 | ) 25 | ) 26 | <*> Opt.optional (Opt.strOption ( Opt.short 'o' 27 | <> Opt.metavar "FILE" 28 | <> Opt.help "output file (default stdout)" 29 | ) 30 | ) 31 | <*> (T.pack <$> Opt.strArgument ( Opt.metavar "STRING" 32 | <> Opt.help "matrix branching program output to specialize for" 33 | ) 34 | ) 35 | 36 | optionsInfo :: Opt.ParserInfo Options 37 | optionsInfo = Opt.info (Opt.helper <*> optionsParser) 38 | ( Opt.fullDesc 39 | <> Opt.progDesc "Turn a multi-output matrix branching program into a single-output one" 40 | ) 41 | 42 | loadSource :: Maybe FilePath -> IO MBP 43 | loadSource source = do 44 | bs <- maybe BS.getContents BS.readFile source 45 | either die return (eitherDecode bs) 46 | 47 | specialize :: Text -> MBP -> Either String MBP 48 | specialize selection m = do 49 | case dims (outputs m) of 50 | (1, _) -> return () 51 | _ -> multiRowOutput 52 | i <- maybe unknownOutput return $ findIndex (selection==) (head (elems (outputs m))) 53 | maybe (columnSelectionFailed i) return $ filterMBP i m 54 | where 55 | filterRow i = take 1 . drop i 56 | filterElems i = map (filterRow i) 57 | filterMatrix i = matrix . filterElems i . elems 58 | filterMap i = traverse (filterMatrix i) 59 | filterStep i s = filterMap i (branches s) >>= step (position s) 60 | filterMBP i m = do 61 | last:init <- return (reverse (steps m)) 62 | last' <- filterStep i last 63 | output' <- filterMatrix i (outputs m) 64 | mbp (reverse (last':init)) output' 65 | 66 | multiRowOutput = Left "Turning multi-row-output programs into evasive programs is not yet implemented." 67 | unknownOutput = Left 68 | $ "The specified matrix branching program does not have " 69 | <> T.unpack selection 70 | <> "\nas an output. Known outputs are:\n" 71 | <> (intercalate "\n" . concat . map (map T.unpack) . elems) (outputs m) 72 | columnSelectionFailed i = Left 73 | $ "The impossible happened: selecting column " 74 | <> show i 75 | <> " from the last matrix of the program violated some invariant." 76 | 77 | saveTarget :: Maybe FilePath -> MBP -> IO () 78 | saveTarget target mbp = maybe BS.putStr BS.writeFile target (encode mbp) 79 | 80 | main :: IO () 81 | main = do 82 | opts <- Opt.execParser optionsInfo 83 | mbp <- loadSource (source opts) 84 | case specialize (selection opts) mbp of 85 | Left err -> die err 86 | Right mbp' -> saveTarget (target opts) mbp' 87 | -------------------------------------------------------------------------------- /images/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all 2 | all: comparison-vanilla.png comparison-base3.png 3 | 4 | %.dot: %.cry 5 | cryfsm $< -o $@ 6 | 7 | %.png: %.dot 8 | dot -Tpng $< >$@ 9 | -------------------------------------------------------------------------------- /images/comparison-base3.cry: -------------------------------------------------------------------------------- 1 | compare x y = if x < y 2 | then "<" 3 | else if x == y 4 | then "=" 5 | else ">" 6 | main : [8] -> String 1 7 | main in = compare x y where 8 | [x, y] = transpose (split (split `{each=2} in)) 9 | valid in = [x <= 2 | x <- split `{each=2} in] == ~zero 10 | grouping = ["l", "l", "r", "r"] 11 | -------------------------------------------------------------------------------- /images/comparison-base3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/GaloisInc/cryfsm/b6b4cd44fb17da4e2695e3e959747463c64c9763/images/comparison-base3.png -------------------------------------------------------------------------------- /images/comparison-vanilla.cry: -------------------------------------------------------------------------------- 1 | compare x y = if x < y 2 | then "<" 3 | else if x == y 4 | then "=" 5 | else ">" 6 | main : [6] -> String 1 7 | main input = compare x y where 8 | [x, y] = transpose (split input) 9 | valid _ = True 10 | grouping = ["l", "r"] 11 | -------------------------------------------------------------------------------- /images/comparison-vanilla.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/GaloisInc/cryfsm/b6b4cd44fb17da4e2695e3e959747463c64c9763/images/comparison-vanilla.png -------------------------------------------------------------------------------- /numfsm.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.State (StateT, get, put, runStateT) 2 | import Control.Monad.Writer (Writer, runWriter, tell) 3 | import Data.Aeson (FromJSON(parseJSON), Value(Number, Object), (.:), eitherDecode, encode) 4 | import Data.Aeson.Types (typeMismatch) 5 | import Data.Foldable (fold, traverse_) 6 | import Data.List (nub) 7 | import Data.Maybe (fromMaybe) 8 | import Data.MBP (MBP, Position, Step, Symbol, branches, position, steps) 9 | import Data.Monoid ((<>)) 10 | import Data.Set (Set) 11 | import Data.String (fromString) 12 | import Data.Text (Text, unpack) 13 | import Data.TotalMap (TMap, fromPartial) 14 | import System.Exit (die) 15 | import System.IO (hPutStrLn, stderr) 16 | import qualified Data.ByteString.Lazy as LBS 17 | import qualified Data.Map as M 18 | import qualified Data.HashMap.Strict as H 19 | import qualified Data.Set as S 20 | import qualified Data.TotalMap as TM 21 | import qualified Options.Applicative as Opt 22 | 23 | newtype Source = Source (TMap Position (Maybe Integer)) 24 | 25 | data Options target = Options 26 | { source :: Source 27 | , target :: target 28 | } 29 | 30 | instance FromJSON Source where 31 | parseJSON n@(Number _) = Source . pure . pure <$> parseJSON n 32 | parseJSON o@(Object _) = Source . fromPartial Nothing . fmap Just <$> parseJSON o 33 | parseJSON v = typeMismatch "number or map from positions to numbers" v 34 | 35 | loadTarget :: Options FilePath -> IO (Options MBP) 36 | loadTarget o = do 37 | bs <- LBS.readFile (target o) 38 | case eitherDecode bs of 39 | Right mbp -> pure (o { target = mbp }) 40 | Left err -> die $ "Could not read state machine in " ++ target o ++ ":\n" ++ err 41 | 42 | sourceParser :: Opt.ReadM Source 43 | sourceParser = do 44 | s <- Opt.str 45 | case eitherDecode . fromString $ s of 46 | Right source -> return source 47 | Left err -> fail $ "tried parsing source as JSON, but failed:\n" ++ err 48 | 49 | optionsParser :: Opt.Parser (Options FilePath) 50 | optionsParser = Options 51 | <$> Opt.argument sourceParser 52 | ( Opt.metavar "SOURCE" 53 | <> Opt.help "JSON value with a number to rebase" 54 | ) 55 | <*> Opt.argument Opt.str 56 | ( Opt.metavar "TARGET" 57 | <> Opt.help "JSON file with a description of a state machine to rebase for" 58 | ) 59 | 60 | optionsInfo :: Opt.ParserInfo (Options FilePath) 61 | optionsInfo = Opt.info (Opt.helper <*> optionsParser) 62 | ( Opt.fullDesc 63 | <> Opt.progDesc "Convert base-10 numbers into suitable symbols for use with a state machine." 64 | ) 65 | 66 | data Warning = Unused | Underused deriving (Bounded, Enum, Eq, Ord, Read, Show) 67 | 68 | showWarning :: Warning -> String 69 | showWarning Unused = "Some positions found in the source were not mentioned in the target." 70 | showWarning Underused = "Some positions found in the source were not completely consumed while rebasing." 71 | 72 | set :: Ord k => k -> v -> TMap k v -> TMap k v 73 | set k v tm = fromMaybe <$> tm <*> fromPartial Nothing (M.singleton k (Just v)) 74 | 75 | step :: Step -> StateT Source (Writer [Position]) Symbol 76 | step s = do 77 | Source tm <- get 78 | case tm TM.! position s of 79 | Nothing -> tell [position s] >> return mempty 80 | Just n -> case divMod n (fromIntegral (M.size (branches s))) of 81 | (n', i) -> put (Source (set (position s) (Just n') tm)) 82 | >> return (fst (M.elemAt (fromIntegral i) (branches s))) 83 | 84 | rebase :: Options MBP -> Either [Position] (Set Warning, [Symbol]) 85 | rebase Options { source = s@(Source s_), target = mbp } 86 | = case runWriter (runStateT (mapM step (reverse (steps mbp))) s) of 87 | (_ , ps@(_:_)) -> Left (nub ps) 88 | ((result, Source s'_), [] ) -> Right (warning, reverse result) where 89 | warning 90 | = fold (TM.codomain (findWarning <$> s_ <*> s'_)) 91 | S.\\ if S.member Nothing (TM.codomain s_) 92 | then S.empty 93 | else S.singleton Unused 94 | 95 | findWarning Nothing _ = S.empty 96 | findWarning (Just v) (Just 0 ) = S.empty 97 | findWarning (Just v) (Just v') = S.singleton 98 | (if v == v' then Unused else Underused) 99 | 100 | main :: IO () 101 | main = do 102 | opts <- Opt.execParser optionsInfo >>= loadTarget 103 | case rebase opts of 104 | Left missing -> die 105 | $ "The following positions were found in the target but not in the source:\n" 106 | ++ unlines (map unpack missing) 107 | Right (warning, result) -> do 108 | traverse_ (hPutStrLn stderr . showWarning) warning 109 | LBS.putStr (encode result) 110 | --------------------------------------------------------------------------------