diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2019 Jared Tobin + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lib/Urbit/Ob.hs b/lib/Urbit/Ob.hs new file mode 100644 --- /dev/null +++ b/lib/Urbit/Ob.hs @@ -0,0 +1,8 @@ + +module Urbit.Ob ( + module E + ) where + +import Urbit.Ob.Co as E +import Urbit.Ob.Muk as E +import Urbit.Ob.Ob as E diff --git a/lib/Urbit/Ob/Co.hs b/lib/Urbit/Ob/Co.hs new file mode 100644 --- /dev/null +++ b/lib/Urbit/Ob/Co.hs @@ -0,0 +1,134 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Urbit.Ob.Co ( + Patp + , render + + , patp + , fromPatp + ) where + +import qualified Data.ByteString as BS +import qualified Data.IntMap.Strict as IMS +import Data.Maybe (fromMaybe) +import qualified Data.Serialize as C +import qualified Data.Text as T +import Data.Word (Word8, Word16, Word) +import Urbit.Ob.Ob (fein, fynd) + +newtype Patp = Patp BS.ByteString + deriving (Eq, Show) + +-- | Convert a nonnegative Int to a Patp value. +patp :: Int -> Patp +patp n + | n >= 0 = _patp + | otherwise = error "urbit-hob (patp): input out of range" + where + sxz = fein n + sxz8 = fromIntegral sxz :: Word8 + + _patp + | met 3 sxz <= 1 = Patp (BS.cons 0 (BS.singleton sxz8)) + | otherwise = Patp (C.encode (fromIntegral sxz :: Word)) + +-- | Convert a Patp value to an Int. +fromPatp :: Patp -> Int +fromPatp (Patp p) = decoded where + decoded = case BS.length p of + 2 -> case C.decode p :: Either String Word16 of + Left _ -> internalErr "fromPatp" + Right x -> fynd (fromIntegral x) + _ -> case C.decode p :: Either String Word of + Left _ -> internalErr "fromPatp" + Right x -> fynd (fromIntegral x) + +-- | Render a Patp value as Text. +render :: Patp -> T.Text +render (Patp p) = prefixed where + grab = fromMaybe (internalErr "render") + + prefixed = case T.uncons encoded of + Just ('-', pp) -> T.cons '~' pp + Just _ -> T.cons '~' encoded + _ -> internalErr "render" + + encoded = foldr alg mempty pruned where + alg (idx, x) acc + | odd idx = grab (IMS.lookup (fromIntegral x) suffixes) <> acc + | otherwise = "-" <> grab (IMS.lookup (fromIntegral x) prefixes) <> acc + + pruned = + let len = BS.length p + indexed = zip [len, pred len..] (BS.unpack p) + padding (idx, val) = idx /= 1 && val == 0 + in dropWhile padding indexed + +prefixes :: IMS.IntMap T.Text +prefixes = IMS.fromList $ zip [0..] + ["doz","mar","bin","wan","sam","lit","sig","hid","fid","lis","sog","dir" + ,"wac","sab","wis","sib","rig","sol","dop","mod","fog","lid","hop","dar" + ,"dor","lor","hod","fol","rin","tog","sil","mir","hol","pas","lac","rov" + ,"liv","dal","sat","lib","tab","han","tic","pid","tor","bol","fos","dot" + ,"los","dil","for","pil","ram","tir","win","tad","bic","dif","roc","wid" + ,"bis","das","mid","lop","ril","nar","dap","mol","san","loc","nov","sit" + ,"nid","tip","sic","rop","wit","nat","pan","min","rit","pod","mot","tam" + ,"tol","sav","pos","nap","nop","som","fin","fon","ban","mor","wor","sip" + ,"ron","nor","bot","wic","soc","wat","dol","mag","pic","dav","bid","bal" + ,"tim","tas","mal","lig","siv","tag","pad","sal","div","dac","tan","sid" + ,"fab","tar","mon","ran","nis","wol","mis","pal","las","dis","map","rab" + ,"tob","rol","lat","lon","nod","nav","fig","nom","nib","pag","sop","ral" + ,"bil","had","doc","rid","moc","pac","rav","rip","fal","tod","til","tin" + ,"hap","mic","fan","pat","tac","lab","mog","sim","son","pin","lom","ric" + ,"tap","fir","has","bos","bat","poc","hac","tid","hav","sap","lin","dib" + ,"hos","dab","bit","bar","rac","par","lod","dos","bor","toc","hil","mac" + ,"tom","dig","fil","fas","mit","hob","har","mig","hin","rad","mas","hal" + ,"rag","lag","fad","top","mop","hab","nil","nos","mil","fop","fam","dat" + ,"nol","din","hat","nac","ris","fot","rib","hoc","nim","lar","fit","wal" + ,"rap","sar","nal","mos","lan","don","dan","lad","dov","riv","bac","pol" + ,"lap","tal","pit","nam","bon","ros","ton","fod","pon","sov","noc","sor" + ,"lav","mat","mip","fip"] + +suffixes :: IMS.IntMap T.Text +suffixes = IMS.fromList $ zip [0..] + ["zod","nec","bud","wes","sev","per","sut","let","ful","pen","syt","dur" + ,"wep","ser","wyl","sun","ryp","syx","dyr","nup","heb","peg","lup","dep" + ,"dys","put","lug","hec","ryt","tyv","syd","nex","lun","mep","lut","sep" + ,"pes","del","sul","ped","tem","led","tul","met","wen","byn","hex","feb" + ,"pyl","dul","het","mev","rut","tyl","wyd","tep","bes","dex","sef","wyc" + ,"bur","der","nep","pur","rys","reb","den","nut","sub","pet","rul","syn" + ,"reg","tyd","sup","sem","wyn","rec","meg","net","sec","mul","nym","tev" + ,"web","sum","mut","nyx","rex","teb","fus","hep","ben","mus","wyx","sym" + ,"sel","ruc","dec","wex","syr","wet","dyl","myn","mes","det","bet","bel" + ,"tux","tug","myr","pel","syp","ter","meb","set","dut","deg","tex","sur" + ,"fel","tud","nux","rux","ren","wyt","nub","med","lyt","dus","neb","rum" + ,"tyn","seg","lyx","pun","res","red","fun","rev","ref","mec","ted","rus" + ,"bex","leb","dux","ryn","num","pyx","ryg","ryx","fep","tyr","tus","tyc" + ,"leg","nem","fer","mer","ten","lus","nus","syl","tec","mex","pub","rym" + ,"tuc","fyl","lep","deb","ber","mug","hut","tun","byl","sud","pem","dev" + ,"lur","def","bus","bep","run","mel","pex","dyt","byt","typ","lev","myl" + ,"wed","duc","fur","fex","nul","luc","len","ner","lex","rup","ned","lec" + ,"ryd","lyd","fen","wel","nyd","hus","rel","rud","nes","hes","fet","des" + ,"ret","dun","ler","nyr","seb","hul","ryl","lud","rem","lys","fyn","wer" + ,"ryc","sug","nys","nyl","lyn","dyn","dem","lux","fed","sed","bec","mun" + ,"lyr","tes","mud","nyt","byr","sen","weg","fyr","mur","tel","rep","teg" + ,"pec","nel","nev","fes"] + +bex :: Integral a => a -> a +bex = (^) 2 + +rsh :: Integral a => a -> a -> a -> a +rsh a b c = c `div` bex (bex a * b) + +met :: Integral a => a -> a -> a +met = loop 0 where + loop !acc a !b + | b == 0 = acc + | otherwise = loop (succ acc) a (rsh a 1 b) + +internalErr :: String -> a +internalErr fn = error $ + "urbit-hob (" <> fn <> "): internal error -- please report this as a bug!" + diff --git a/lib/Urbit/Ob/Muk.hs b/lib/Urbit/Ob/Muk.hs new file mode 100644 --- /dev/null +++ b/lib/Urbit/Ob/Muk.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -Wall #-} + +module Urbit.Ob.Muk ( + muk + ) where + +import Data.Bits +import qualified Data.ByteString.Char8 as B8 +import Data.Char +import Data.Word (Word32) +import qualified Data.Hash.Murmur as M + +-- | A specific murmur3 variant. +muk :: Word32 -> Word32 -> Word32 +muk syd key = M.murmur3 syd kee where + kee = chr lo `B8.cons` chr hi `B8.cons` mempty + lo = fromIntegral (key .&. 0xFF) + hi = fromIntegral (key .&. 0xFF00 `div` 256) + diff --git a/lib/Urbit/Ob/Ob.hs b/lib/Urbit/Ob/Ob.hs new file mode 100644 --- /dev/null +++ b/lib/Urbit/Ob/Ob.hs @@ -0,0 +1,178 @@ +{-# OPTIONS_GHC -Wall #-} + +module Urbit.Ob.Ob ( + fein + , fynd + , feis + , tail + , fe + , fen + , capF + , capFe + , capFen + ) where + +import Data.Bits +import Data.Word (Word32) +import Urbit.Ob.Muk (muk) +import Prelude hiding (tail) + +-- | Conceal structure v3. +fein :: (Integral a, Bits a) => a -> a +fein = loop where + loop pyn = + let lo = pyn .&. 0xFFFFFFFF + hi = pyn .&. 0xFFFFFFFF00000000 + p32 = fromIntegral pyn :: Word32 + in if pyn >= 0x10000 && pyn <= 0xFFFFFFFF + then 0x10000 + fromIntegral (feis (p32 - 0x10000)) + else if pyn >= 0x100000000 && pyn <= 0xFFFFFFFFFFFFFFFF + then hi .|. loop lo + else pyn + +-- | Restore structure v3. +fynd :: (Integral a, Bits a) => a -> a +fynd = loop where + loop cry = + let lo = cry .&. 0xFFFFFFFF + hi = cry .&. 0xFFFFFFFF00000000 + c32 = fromIntegral cry :: Word32 + in if cry >= 0x10000 && cry <= 0xFFFFFFFF + then 0x10000 + fromIntegral (tail (c32 - 0x10000)) + else if cry >= 0x100000000 && cry <= 0xFFFFFFFFFFFFFFFF + then hi .|. loop lo + else cry + +-- | Generalised Feistel cipher +-- +-- See: Black and Rogaway (2002), "Ciphers with arbitrary finite domains." +-- +-- Note that this has been adjusted from the reference paper in order to +-- support some legacy behaviour. +feis :: Word32 -> Word32 +feis = capFe 4 65535 65536 0xFFFFFFFF capF + +-- | Reverse 'feis'. +-- +-- See: Black and Rogaway (2002), "Ciphers with arbitrary finite domains." +-- +-- Note that this has been adjusted from the reference paper in order to +-- support some legacy behaviour. +tail :: Word32 -> Word32 +tail = capFen 4 65535 65536 0xFFFFFFFF capF + +-- | A PRF for j in [0, .., 3] +capF :: Int -> Word32 -> Word32 +capF j key = fromIntegral (muk seed key) where + seed = raku !! fromIntegral j + raku = [ + 0xb76d5eed + , 0xee281300 + , 0x85bcae01 + , 0x4b387af7 + ] + +-- | 'Fe' in B&R (2002). +capFe + :: Integral a + => Int + -> a + -> a + -> a + -> (Int -> a -> a) + -> a + -> a +capFe r a b k f m + | c < k = c + | otherwise = fe r a b f c + where + c = fe r a b f m + +-- | 'fe' in B&R (2002). +fe + :: Integral a + => Int + -> a + -> a + -> (Int -> a -> a) + -> a + -> a +fe r a b f m = loop 1 capL capR where + capL = m `mod` a + capR = m `div` a + loop j ell arr + | j > r = + if odd r + then a * arr + ell + else if arr == a + then a * arr + ell + else a * ell + arr + | otherwise = + let eff = f (pred j) arr + tmp = if odd j + then (ell + eff) `mod` a + else (ell + eff) `mod` b + in loop (succ j) arr tmp + +-- | 'Fen' in B&R (2002). +capFen + :: Integral a + => Int + -> a + -> a + -> a + -> (Int -> a -> a) + -> a + -> a +capFen r a b k f m + | c <= k = c + | otherwise = fen r a b f c + where + c = fen r a b f m + +-- | 'fen' in B&R (2002). +fen + :: Integral a + => Int + -> a + -> a + -> (Int -> a -> a) + -> a + -> a +fen r a b f m = loop r capL capR where + ahh = + if odd r + then m `div` a + else m `mod` a + + ale = + if odd r + then m `mod` a + else m `div` a + + capL = + if ale == a + then ahh + else ale + + capR = + if ale == a + then ale + else ahh + + loop j ell arr + | j < 1 = a * arr + ell + | otherwise = + let eff = f (pred j) ell + -- NB (jtobin): + -- + -- Slight deviation from B&R (2002) here to prevent negative + -- values. We add 'a' or 'b' to arr as appropriate and reduce + -- 'eff' modulo the same number before performing subtraction. + -- + tmp = if odd j + then (arr + a - (eff `mod` a)) `mod` a + else (arr + b - (eff `mod` b)) `mod` b + in loop (pred j) tmp ell + + diff --git a/test/Small.hs b/test/Small.hs new file mode 100644 --- /dev/null +++ b/test/Small.hs @@ -0,0 +1,47 @@ +module Main where + +import Control.Monad (unless) +import Data.List (nub, foldl') +import Prelude hiding (tail) +import System.Exit (exitSuccess, exitFailure) +import qualified Urbit.Ob.Ob as Ob + +a, b, c :: Int +a = 2 ^ 2 - 1 +b = 2 ^ 2 +c = a * b + +eff j m = + let v0 = [5, 9, 2, 6, 4, 0, 8, 7, 1, 10, 3, 11] + v1 = [2, 1, 0, 3, 10, 4, 9, 5, 7, 11, 6, 8] + v2 = [10, 6, 7, 1, 0, 11, 3, 9, 5, 2, 8, 4] + v3 = [11, 0, 3, 5, 9, 8, 6, 10, 4, 1, 2, 7] + + in case j of + 0 -> v0 !! m + 1 -> v1 !! m + 2 -> v2 !! m + _ -> v3 !! m + +feis = Ob.capFe 4 a b c eff + +tail = Ob.capFen 4 a b c eff + +main :: IO () +main = do + let emm = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11] + perm = fmap feis emm + inv = fmap tail perm + distincts = nub perm + + let distinctElems = length distincts == length perm + unless distinctElems exitFailure + + let permuteSuccessful = foldl' (\acc x -> x `elem` emm && acc) True perm + unless permuteSuccessful exitFailure + + let tailInvertsFeis = emm == inv + unless tailInvertsFeis exitFailure + + exitSuccess + diff --git a/urbit-hob.cabal b/urbit-hob.cabal new file mode 100644 --- /dev/null +++ b/urbit-hob.cabal @@ -0,0 +1,77 @@ +name: urbit-hob +version: 0.1.0 +synopsis: Hoon-style atom manipulation and printing functions +homepage: https://github.com/urbit/urbit-hob#readme +bug-reports: https://github.com/urbit/urbit-hob/issues +author: Jared Tobin +maintainer: jared@jtobin.io +copyright: 2019 Jared Tobin +category: Urbit +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +description: + Here you can primarily find functions for dealing with the "patp" phonetic + base used by Urbit. The '@p' encoding is used for naming ships; it uniquely + represents a 32-bit number in a memorable and pronounceable fashion. + . + The '@p' encoding is an obfuscated representation of an underlying 32-bit + number, in particular, hence the 'ob' in the library's name. + . + The library exposes two functions, 'patp' and 'fromPatp', for converting + between representations. You can render a 'Patp' value via the 'render' + function. + . + Here's a quick example: + . + > import qualified Urbit.Ob as Ob + > + > let nidsut = Ob.patp 15663360 + > Ob.render nidsut + "~nidsut-tomdun" + > Ob.fromPatp nidsut + 15663360 + +source-repository head + type: git + location: https://github.com/urbit/urbit-hob + +flag release + Description: Build for release + Default: False + Manual: True + +library + default-language: Haskell2010 + hs-source-dirs: lib + + if flag(release) + ghc-options: -Wall + else + ghc-options: -Wall -Werror + + exposed-modules: + Urbit.Ob + , Urbit.Ob.Co + , Urbit.Ob.Muk + , Urbit.Ob.Ob + build-depends: + base >= 4.7 && < 6 + , bytestring >= 0.10 && < 1 + , cereal >= 0.5 && < 1 + , containers >= 0.5 && < 1 + , murmur3 >= 1.0 && < 2 + , text >= 1.2 && < 2 + +Test-suite small + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Small.hs + default-language: Haskell2010 + ghc-options: + -rtsopts + build-depends: + base + , urbit-hob +