Commit 449f4604 authored by Marc Coiffier's avatar Marc Coiffier
Browse files

First commit

parents
# Revision history for curly-core
## 0.1.0.0 -- YYYY-mm-dd
* First version. Released on an unsuspecting world.
Copyright (c) 2017 Marc Coiffier
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.
import Distribution.Simple
main = defaultMain
-- Initial curly-core.cabal generated by cabal init. For further
-- documentation, see http://haskell.org/cabal/users-guide/
name: curly-core
version: 0.2.4
-- synopsis:
-- description:
license: MIT
license-file: LICENSE
author: Marc Coiffier
maintainer: marc.coiffier@univ-grenoble-alpes.fr
-- copyright:
-- category:
build-type: Simple
extra-source-files: ChangeLog.md
cabal-version: >=1.10
library
exposed-modules: Curly.Core, Curly.Core.Library, Curly.Core.Types, Curly.Core.Security, Curly.Core.Peers, Curly.Core.Parser, Curly.Core.Annotated, Curly.Core.VCS, Curly.Core.Security.EC, Curly.Core.VCS.Diff
-- other-modules:
default-extensions: RebindableSyntax
FlexibleInstances
MultiParamTypeClasses
FlexibleContexts
FunctionalDependencies
TypeOperators
TupleSections
ImplicitParams
GeneralizedNewtypeDeriving
RankNTypes
DeriveGeneric
AllowAmbiguousTypes
other-extensions: UndecidableInstances, ScopedTypeVariables, StandaloneDeriving, PatternSynonyms, ViewPatterns, TypeFamilies, CPP, RecursiveDo, GADTs, DeriveGeneric, OverloadedStrings, NoMonomorphismRestriction, DeriveDataTypeable, ExistentialQuantification, BangPatterns
build-depends: base >=4.10 && <4.11, definitive-base, definitive-network, definitive-parser, definitive-filesystem, cryptohash, network, entropy, AES >=0.2 && <0.3, deepseq >=1.4 && <1.5, directory >=1.3 && <1.4, hinotify >=0.3 && <0.4, base64-bytestring >=1.0 && <1.1, process >=1.6 && <1.7, zlib >=0.6 && <0.7, containers >=0.5 && <0.6
hs-source-dirs: src
default-language: Haskell2010
{-# LANGUAGE UndecidableInstances, ScopedTypeVariables, StandaloneDeriving, PatternSynonyms, ViewPatterns #-}
module Curly.Core(
-- * Expressions
ExprNode(..),Expression,
Identifier(..),HasIdents(..),Builtin(..),
SemanticT(..),Semantic(..),mkAbstract,mkSymbol,mkApply,sem,
pattern PatSymbol,pattern PatAbstract,pattern PatApply,pattern PatApply2,
-- ** Utilities
c'Expression,syntax,semantic,mapParams,
-- * Pretty-printing
Pretty(..),pretty,indent,(</>),FormatArg(..),FormatType(..),format,
-- * Environment
envVar,curlyUserDir,curlyKeysFile,curlyCacheDir,curlyCommitDir,curlyPort,
-- * Conditional output
LogLevel(..),envLogLevel,logLine,trylogLevel,trylog,liftIOLog,cyDebug,
-- * Misc
PortNumber,watchFile,connectTo,(*+)
) where
import Definitive
import Language.Format
import Control.DeepSeq
import IO.Filesystem ((</>))
import IO.Network.Socket (PortNumber,connect,getAddrInfo)
import System.Directory (createDirectoryIfMissing)
import System.Environment (lookupEnv)
import System.INotify
import System.IO (openFile,IOMode(AppendMode),hSetBuffering,BufferMode(LineBuffering))
import qualified Data.ByteString.Base64 as Base64
{-| The type of an expression node
This type is used in combination with others within Free functors to
model expressions with different attributes.
-}
data ExprNode s a = Apply a a
| Lambda s a
deriving (Eq,Ord,Show,Generic)
instance (NFData s,NFData a) => NFData (ExprNode s a) where
rnf (Apply x y) = rnf x`seq`rnf y`seq`()
rnf (Lambda s e) = rnf s`seq`rnf e`seq`()
-- | The type of a simple Curly expression
type Expression s a = Free (ExprNode s) a
instance Functor (ExprNode s) where
map f (Apply a b) = Apply (f a) (f b)
map f (Lambda s a) = Lambda s (f a)
instance Foldable (ExprNode s) where
fold (Lambda _ a) = a
fold (Apply a b) = a+b
instance Traversable (ExprNode s) where
sequence (Lambda s a) = Lambda s<$>a
sequence (Apply ff fx) = Apply<$>ff<*>fx
instance (Serializable a,Serializable s) => Serializable (ExprNode s a)
instance (Format a,Format s) => Format (ExprNode s a)
instance (Serializable (f (Free f a)),Serializable a) => Serializable (Free f a) where
encode (Pure s) = encodeAlt 0 s
encode (Join f) = encodeAlt 1 f
instance (Format (f (Free f a)),Format a) => Format (Free f a) where
datum = datumOf [FormatAlt Pure,FormatAlt Join]
instance (Serializable (f (Cofree f a)),Serializable a) => Serializable (Cofree f a) where
encode (Step a fc) = encode (a,fc)
instance (Format (f (Cofree f a)),Format a) => Format (Cofree f a) where
datum = uncurry Step<$>datum
c'Expression :: Constraint (Expression a b)
c'Expression = c'_
data SemanticT e i o = SemApply e e
| SemAbstract i e
| SemSymbol o
{- | The class of all lambda-like expressions.
This class provides an abstraction of the different types used to
represent expressions at the different stages of compilation.
This class provides three constructors and a destructor for its
target type, allowing abstract pattern-matching to take place.
-}
class Semantic e i o | e -> i o where
semNode :: Iso' e (SemanticT e i o)
instance Semantic (Free (ExprNode s) a) s a where
semNode = iso f g
where f (Pure s) = SemSymbol s
f (Join (Lambda s e)) = SemAbstract s e
f (Join (Apply a b)) = SemApply a b
g (SemSymbol s) = Pure s
g (SemAbstract s e) = Join (Lambda s e)
g (SemApply a b) = Join (Apply a b)
sem :: Semantic e i o => e -> SemanticT e i o
sem = by semNode
mkSymbol x = SemSymbol x^..semNode
mkAbstract s e = SemAbstract s e^..semNode
mkApply a b = SemApply a b^..semNode
pattern PatSymbol s <- (sem -> SemSymbol s)
pattern PatAbstract s e <- (sem -> SemAbstract s e)
pattern PatApply f x <- (sem -> SemApply f x)
pattern PatApply2 f x y <- PatApply (PatApply f x) y
-- | Transform a lambda-like expression into another
semantic :: (Semantic e i o, Semantic e' i o) => e -> e'
semantic e = case sem e of
SemSymbol s -> mkSymbol s
SemAbstract i e' -> mkAbstract i (semantic e')
SemApply f x -> mkApply (semantic f) (semantic x)
-- | Tranform an expression into another, annotating it with contextual information.
{-# INLINE syntax #-}
syntax :: (Semantic e i o,Semantic e' i o'',Ord i) => (o -> o' -> o'') -> (o -> o') -> (o -> i) -> (Int -> o') -> e -> e'
syntax cons val name loc = syn (zero :: Int,c'map zero)
where syn (n,m) = fix $ \syn' e -> case sem e of
SemSymbol o -> mkSymbol $ cons o $ maybe (val o) (loc . \m -> (n-m)-1) (m^.at (name o))
SemAbstract i e' -> mkAbstract i (syn (n+1,insert i n m) e')
SemApply f x -> mkApply (syn' f) (syn' x)
-- | Maps a function over lambda parameters in an expression
mapParams :: (Semantic e i o,Semantic e' i' o) => (i -> i') -> e -> e'
mapParams f = doMap
where doMap x = case sem x of
SemSymbol s -> mkSymbol s
SemAbstract s e -> mkAbstract (f s) (doMap e)
SemApply a b -> mkApply (doMap a) (doMap b)
-- | A type for objects that should be printed prettily
newtype Pretty a = Pretty a
-- | A shortcut for @show . Pretty@
pretty :: Show (Pretty a) => a -> String
pretty = show . Pretty
-- | Prepend the second to each line of the first.
indent :: String -> String -> String
indent p s = p+indent' s
where indent' ('\n':t) = '\n':(p+indent' t)
indent' [] = []
indent' (c:t) = c:indent' t
instance Show (Pretty String) where show (Pretty s) = s
instance Show (Pretty Int) where show (Pretty n) = show n
instance (Show (Pretty s),Show (Pretty a)) => Show (Pretty (Expression s a)) where
show (Pretty expr) = show' "" expr
where
show' :: forall a' s'. (Show (Pretty a'),Show (Pretty s')) => String -> Expression s' a' -> String
show' h (Pure s) = h+"-> "+pretty s
show' h (Join (Lambda s e@(Join (Lambda _ _)))) = h+"<- "+pretty s+" "+drop (length h+4) (show' h e)
show' h (Join (Lambda s e)) = h+"<- "+pretty s+"\n"+show' (h+"| ") e
show' h (Join (Apply (Join (Apply f (Pure x1))) (Pure x2)))
= show' h (Join (Apply (map pretty f) (Pure (pretty x1+" "+pretty x2))))
show' h (Join (Apply (Pure f) (Pure x))) = h+"-> "+pretty f+"("+pretty x+")"
show' h (Join (Apply f x)) = show' h f+"\n"
+show' (h+"- ") x
instance Show (Pretty Chunk) where
show (Pretty l) = foldMap to $ Base64.encode l^.i'elems
where to '/' = "-"
to '+' = "_"
to '=' = []
to x = [x]
instance Read (Pretty Chunk) where
readsPrec _ = readsParser $ do
let from '-' = '/'
from '_' = '+'
from x = x
pad c = c+take (negate (length c)`mod`4) "===="
c <- many' (from <$> satisfy p)
(const zero <|> return . Pretty) (Base64.decode (pad c^..i'elems))
where p x = inside 'a' 'z' x || inside 'A' 'Z' x || inside '0' '9' x || x=='_' || x=='-'
-- | `envVar def var` retrieves a `var` from the environment, or returns `def` if the former doesn't exist
envVar :: String -> String -> String
envVar d s = fromMaybe d (lookupEnv s^.thunk)
curlyDirPath :: String -> String
curlyDirPath dir = (createDirectoryIfMissing True dir^.thunk)`seq`dir
-- | The default Curly port for library proxies and the portmapper
curlyPort :: PortNumber
curlyPort = fromMaybe 25465 $ matches Just number (envVar "" "CURLY_PORT")
-- | A user-writable directory to store Curly configurations
curlyUserDir :: String
curlyUserDir = curlyDirPath $ envVar "/tmp" "HOME"+"/.curly"
-- | The path of the Curly key wallet
curlyKeysFile :: String
curlyKeysFile = curlyUserDir + "/keys"
-- | The path to the user's cache directory
curlyCacheDir :: String
curlyCacheDir = curlyDirPath $ envVar (curlyUserDir + "/libraries") "CURLY_LIBCACHE"
curlyCommitDir :: String
curlyCommitDir = curlyDirPath (curlyUserDir + "/commits")
-- | A Curly log level
data LogLevel = Quiet | Verbose | Debug
deriving (Eq,Ord)
-- The global log level, as set by the environment variable CURLY_LOGLEVEL
envLogLevel = envVar "quiet" "CURLY_LOGLEVEL"
& fromMaybe Quiet . matches Just (foldl1' (<+?) [x<$several s | (x,s) <- levels])
where levels = [(Quiet,"quiet"),(Verbose,"verbose"),(Debug,"debug")]
-- | Logs a line to stderr if the environment log level is greater than the given threshold
logLine :: MonadIO m => LogLevel -> String -> m ()
logLine level | envLogLevel>=level = \str -> liftIO $ logFile`seq`writeHString logFile (str+"\n")
| otherwise = const unit
cyDebug :: Show a => a -> a
cyDebug | envLogLevel >= Debug = debug
| otherwise = id
-- | A global handle to a log file (avoids reopening the same file over and over again)
logFile :: Handle
logFile = case envVar "" "CURLY_LOGFILE" of
"" -> stderr
f -> (openFile f AppendMode <*= \h -> hSetBuffering h LineBuffering)^.thunk
-- | A class for all types that can be formatted to a string
class Show a => FormatArg a where
argClass :: a -> Char
showFormat :: a -> String
showFormat = show
-- | A base class for the 'format' function
class FormatType a where
format' :: String -> String -> a
instance (FormatArg a,FormatType r) => FormatType (a -> r) where
format' x ('%':c:t) a | c == argClass a = format' (reverse (showFormat a)+x) t
| otherwise = error "Invalid format argument type"
format' x (c:t) a = format' (c:x) t a
format' _ [] _ = error "Unused argument in format"
instance FormatType String where
format' x t = reverse x+t
instance FormatArg Int where argClass _ = 'd'
instance FormatArg Float where argClass _ = 'f'
instance FormatArg Double where argClass _ = 'f'
instance FormatArg String where argClass _ = 's'; showFormat = id
instance FormatArg PortNumber where argClass _ = 'p'
instance Show (Pretty a) => FormatArg (Pretty a) where argClass _ = 'a'
-- | Runs an IO action, logging its errors if the given log level is lower than the environment
trylogLevel :: LogLevel -> IO a -> IO a -> IO a
trylogLevel l def = catch (\e -> logLine l (show e) >> def)
-- | Same as `tryLogLevel`, with a log level of `Debug`
trylog :: IO a -> IO a -> IO a
trylog = trylogLevel Debug
-- | A utility function that lifts its argument while logging its errors
liftIOLog :: MonadIO m => IO () -> m ()
liftIOLog = liftIO . trylogLevel Quiet unit
-- | A function that mimics sprintf-style formatting for Haskell
format :: FormatType r => String -> r
format = format' ""
-- | A global INotify instance
inotify = initINotify^.thunk
-- | Sets a watch on the given file, on the usual signals
watchFile s f = addWatch inotify [Modify,Create,Delete,Move,MoveIn,MoveOut,MoveSelf] s (\_ -> f)
-- | A utility function that opens a client socket to the given server and port
connectTo :: String -> PortNumber -> IO Handle
connectTo h p = trylog (error $ format "Couldn't connect to host %s:%p" h p) $ do
connect . head =<< getAddrInfo Nothing (Just h) (Just (show p))
-- | Inclusive-or for `Map`s
(*+) :: (Ord k,Semigroup m) => Map k m -> Map k m -> Map k m
a *+ b = a*b+a+b
{- | The class of Curly identifiers, used mainly to simplify type signatures. -}
class (Ord s,Show s,NFData s) => Identifier s where
pureIdent :: String -> s
identName :: s -> String
instance Identifier String where pureIdent = id; identName = id
instance Identifier Int where
pureIdent = error "Cannot construct numeric identifier from arbitrary string"
identName = show
-- | A useful class for identifier-filled types
class HasIdents s s' t t' | t t' -> s s' where
ff'idents :: FixFold s s' t t'
instance (Traversable f,HasIdents s s' (f (Free f' a)) (f' (Free f' a))) => HasIdents s s' (Free f a) (Free f' a) where
ff'idents k = f
where f (Pure a) = pure (Pure a)
f (Join ffa) = map Join (traverse f ffa >>= traversel ff'idents k)
instance forall s s' g g' f f' a. (Traversable f,HasIdents s s' (g a) (g' a), HasIdents s s' (f (g' a)) (f' (g' a))) => HasIdents s s' ((f:.:g) a) ((f':.:g') a) where
ff'idents k (Compose x) = Compose<$>(traversel (traverse.ff'idents) k x >>= \x -> traversel ff'idents k (x :: f (g' a)))
instance HasIdents s s' (ExprNode s a) (ExprNode s' a) where
ff'idents k (Lambda s a) = k s <&> \s' -> Lambda s' a
ff'idents _ (Apply x y) = pure (Apply x y)
instance HasIdents s s' (s,a) (s',a) where
ff'idents k (s,a) = map (,a) (k s)
instance HasIdents s s' t t' => HasIdents s s' (Maybe t) (Maybe t') where
ff'idents = t'Just.ff'idents
-- | The type of all Curly builtins
data Builtin = B_Undefined
| B_Seq
| B_Unit
| B_Number Int
| B_AddInt | B_SubInt | B_MulInt | B_DivInt
| B_String String
| B_StringLength
| B_AddString | B_ShowInt
| B_FileDesc Int
| B_Open | B_Read | B_Write | B_Close
deriving (Eq,Ord,Show,Generic)
instance Show (Pretty Builtin) where
show (Pretty (B_Number n)) = show n
show (Pretty (B_String s)) = show s
show (Pretty b) = show b
instance Serializable Builtin where
instance Format Builtin where
instance NFData Builtin where rnf b = b`seq`()
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
module Curly.Core.Peers where
import Control.Concurrent.Chan
import Control.Concurrent (forkIO)
import Curly.Core
import Curly.Core.Library
import Data.IORef
import GHC.Conc (threadDelay)
import IO.Network.Socket
import Language.Format
import System.IO (hSetBuffering,BufferMode(..))
data PeerPacket = DeclareInstance String (WithResponse (Either String PortNumber))
| RedeclareInstance String PortNumber (WithResponse Bool)
| DeclareSupply
| AskInstance String (WithResponse (Either String PortNumber))
| AskInstances (WithResponse [String])
| AskLibrary LibraryID (WithResponse Bytes)
| ListLibraries (WithResponse [(LibraryID,Metadata)])
deriving Generic
instance Serializable PortNumber where
encode = encode . c'int . fromIntegral
instance Format PortNumber where
datum = fromIntegral . c'int <$> datum
instance Serializable PeerPacket
instance Format PeerPacket where
datum = defaultDatum
<+? ListLibraries WithResponse <$ sequence_ [datum >>= guard . (==c) | c <- "libraries"]
<+? (\x -> AskLibrary x WithResponse) <$> ((fromMaybe zero . matches Just (many' datum)<$>runStreamState (id <~ swap . splitAt 64)) >*> readable)
data LocalSupply = LocalSupply (IO [(LibraryID,Metadata)]) (LibraryID -> IO (Maybe Bytes))
data SupplyAnswer = SupplyLibraries [(LibraryID,Metadata)]
| SupplyLibrary Bytes
deriving Generic
instance Serializable SupplyAnswer ; instance Format SupplyAnswer
processInstances :: IORef (Set String)
processInstances = newIORef zero^.thunk
peerServer :: IO ()
peerServer = do
sock <- listenOn curlyPort
proxies <- newIORef ([0..],c'map zero)
srvState <- newIORef (c'bimap zero)
timeouts <- newIORef (c'set zero)
let startTimeout inst = do
modifyIORef timeouts (touch inst)
void $ forkIO $ fix $ \again -> do
x <- readIORef timeouts
if inst`isKeyIn`x then modifyIORef timeouts (delete inst) >> threadDelay 5000000 >> again
else do
logLine Verbose $ format "Freeing stale instance '%s'" inst
modifyIORef srvState (delete inst)
void $ forkIO $ forever $ do
(h,addr) <- accept sock
forkIO $ do
runConnection_ True h $ fix $ \again -> receive >>= \x -> case x of
DeclareInstance s t -> do
port <- liftIO $ runAtomic srvState $ get >>= \m -> case lookup s m of
Just _ -> return $ Left ("Error: The instance '"+s+"' is already declared")
_ -> let p = foldr1 (\p ans -> if isKeyIn p (commute m) then ans else p) [curlyPort+1..]
in Right p <$ put (insert s p m)
sending t port
case port of
Right _ -> liftIO $ startTimeout s
_ -> unit
RedeclareInstance s p t -> do
success <- liftIO $ runAtomic srvState $ get >>= \m ->
if isKeyIn p (commute m) || isKeyIn s m then return False else True <$ put (insert s p m)
liftIO $ if success then startTimeout s >> sending t True
else runAtomic timeouts (modify $ touch s) >> threadDelay 4000000 >> sending t False
again
AskInstance s t -> do
m <- liftIO $ readIORef srvState
sending t (maybe (Left $ "Error: Non-existent instance: "+s) Right (lookup s m))
AskInstances t -> do
m <- liftIO $ readIORef srvState
pi <- liftIO $ readIORef processInstances
let (ours,others) = partition (`elem`pi) (keys m)
sending t (c'list others + ours)
DeclareSupply -> do
lists <- liftIO newChan ; libs <- liftIO newChan
let askAll = send (Nothing :: Maybe LibraryID) >> readChan lists
askOne x = case findLib x of
Just l -> return (Just $ l^.flBytes)
_ -> send (Just x) >> readChan libs <&> \d -> d<$guard (isLibData x d)
i <- liftIO $ runAtomic proxies $ id <~ \(i:is,m) -> ((is,insert (i :: Int) (LocalSupply askAll askOne) m),i)
try unit $ forever $ receive >>= liftIO . \x -> case x of
SupplyLibraries ls -> writeChan lists ls
SupplyLibrary l -> writeChan libs l
liftIO $ modifyIORef proxies $ \(is,m) -> (i:is,delete i m)
ListLibraries t -> liftIO $ do
logLine Verbose $ "Request for libraries from "+show addr
(_,ps) <- readIORef proxies
sending t . fold =<< sequence [trylog (return []) askAll | LocalSupply askAll _ <- toList ps]
AskLibrary lid _ -> liftIO $ do
logLine Verbose $ "Request for library "+show lid+" from "+show addr
(_,ps) <- readIORef proxies
let asks = [trylog (return zero) (askOne lid) | LocalSupply _ askOne <- toList ps]
lib <- foldr (\ask rest -> ask >>= maybe rest (return . Just)) (return Nothing) asks
?write (fromMaybe zero lib)
peerClient :: IO Handle
peerClient = do
addrs <- getAddrInfo Nothing (Just "127.0.0.1") (Just (show curlyPort))
h <- fix $ \run -> trylog (trylog unit peerServer >> run) (connect (head addrs))
h <$ hSetBuffering h NoBuffering
{-# LANGUAGE GADTs, DeriveGeneric #-}
module Curly.Core.Security(
-- * Keys and Secrets
Access(..),PrivateKey,PublicKey,SharedSecret,KeyFingerprint,Signature,Signed,
genPrivateKey,publicKey,fingerprint,sharedSecret,signBytes,isValidSignatureFrom,signValue,extractSignedBy,unsafeExtractSigned,
-- * Encryption/Decryption
decrypt,encrypt,
-- * Environment
curlyKeysFile,getKeyStore,modifyKeyStore,
-- * Showing and reading formats
Zesty(..)
) where
import Control.DeepSeq (deepseq)
import Curly.Core
import Curly.Core.Library
import Data.Bits (xor)
import Data.IORef
import GHC.Conc (threadDelay)
import IO.Filesystem
import Language.Format
import qualified Codec.Crypto.AES.IO as AES
import qualified Curly.Core.Security.EC as EC
import qualified Crypto.Hash.SHA256 as SHA256
import System.Entropy
import System.IO
import IO.Time
newtype PrivateKey = PrivateKey Integer
deriving (Eq,Ord)
newtype PublicKey = PublicKey (Integer,Integer)
deriving Show
data Signature = Signature Integer Integer
deriving (Eq,Ord,Generic,Show)
instance Serializable Signature ; instance Format Signature
newtype KeyFingerprint = KeyFingerprint Chunk
deriving (Eq,Ord)
data SharedSecret = SharedSecret { readCxt :: AES.AESCtx, writeCxt :: AES.AESCtx }
data Access = Deny | Read | Run | Write | Admin | Almighty
deriving (Eq,Ord,Enum,Bounded)
instance Show Access where
show Deny = "none"
show Read = "read" ; show Run = "execute" ; show Write = "write"
show Admin = "admin" ; show Almighty = "almighty"
instance Read Access where
readsPrec _ = readsParser $ foldr1 (<+?)
[s<$several n | (n,s) <- [("none",Deny),("read",Read),("execute",Run),("write",Write)
,("admin",Admin),("almighty",Almighty)]]
instance Semigroup Access where (+) = max
instance Monoid Access where zero = minBound
instance Serializable Access where encode a = encode (fromEnum a)
instance Format Access where datum = toEnum <$> datum
-- | This function is useless, but it makes textual representations of data look more
-- "random".
zest :: Bytes -> Bytes
zest bs = pack $ zipWith xor (unpack bs) zestBytes
where zestBytes = sum $ repeat [
0xaa,0x48,0xd1,0x13,0x9b,0x4c,0x7e,0xe2,0x22,0x2e,0xac,0x69,0x90,0x4c,0xdb,0x02,
0x38,0x3c,0x75,0x7a,0x05,0x0b,0x00,0x99,0x59,0x32,0xfa,0x09,0x5d,0x55,0x2b,0xfe,
0x09,0xc6,0xcc,0x3d,0x49,0xfe,0xb6,0x0e,0xa3,0xd1,0xa2,0xf3,0xcd,0xce,0x0e,0x10,
0x48,0xa9,0x89,0x83,0x62,0xe0,0x92,0x81,0x17,0xb1,0xae,0x31,0xba,0xd7,0x60,0xfe,
0x32,0xed,0xb9,0x2d,0xbe,0x4a,0xe2,0x11,0xaa,0x18,0xf5,0x38,0xef,0x19,0x0a,0xac,
0x95,0xd5,0xd6,0x59,0xf9,0xdb,0x8b,0x63,0xc5,0x8c,0x00,0xc2,0x78,0x12,0x22,0x59,
0x99,0x35,0xac,0x00,0x7a,0xd0,0xc1,0x1a,0x34,0x29,0x42,0xd3,0x98,0xe2,0x51,0x57,
0xbb,0xed,0x8f,0xd9,0x24,0xbb,0xd0,0xb1,0x55,0xac,0x04,0x8a,0x29,0x34,0x64,0x8d,
0x0a,0x07,0x9c,0x87,0xb9,0xf3,0x4f,0x9e,0xa4,0xfd,0xda,0xde,0x2e,0x97,0xf8,0xe7,
0x55,0x14,0xb9,0xe9,0xc1,0xeb,0xa2,0x48,0x16,0x57,0xe9,0xa3,0x2c,0x27,0x32,0xc7,
0xd9,0x04,0x25,0xe3,0x7b,0x27,0x31,0x6a,0x49,0x68,0x32,0xe1,0x77,0x0f,0x01,0x22,
0x06,0xa4,0xc5,0x80,0xa6,0xe8,0x4f,0x0f,0x01,0xc5,0xfc,0x5f,0xc7,0x44,0x0b,0x08,
0xc5,0x04,0x0e,0x4c,0xf7,0x77,0x14,0x63,0x66,0x41,0xfb,0x35,0x67,0xca,0x9f,0xa8,