special-keys (empty) → 0.1.0.0
raw patch · 6 files changed
+310/−0 lines, 6 filesdep +basedep +blaze-markupdep +bytestringsetup-changed
Dependencies added: base, blaze-markup, bytestring, cereal, deepseq, hashable, path-pieces, primitive, safecopy, text
Files
- Keys/Constraints.hs +109/−0
- Keys/Random.hs +63/−0
- Keys/UUID.hs +77/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- special-keys.cabal +29/−0
+ Keys/Constraints.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE RankNTypes, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+module Keys.Constraints+ ( Text128+ , Text256+ , Text512+ , Text1024+ , Text2048+ , Text4096+ , TextConstraint(..)+ , t128+ , t256+ , t512+ , t1024+ , t2048+ , t4096) where+import Prelude+import qualified Data.Text as T+import Data.Data+import Data.String+import Data.Monoid+import Control.DeepSeq+import Data.SafeCopy+import Data.Serialize+import Data.Text.Encoding+import Data.Hashable++-- | Text with a maximum of 128 characters+newtype Text128 = Text128 T.Text deriving(Eq, Data, Ord, Read, Show, Typeable, IsString, Monoid, NFData)+newtype Text256 = Text256 T.Text deriving(Eq, Data, Ord, Read, Show, Typeable, IsString, Monoid, NFData)+newtype Text512 = Text512 T.Text deriving(Eq, Data, Ord, Read, Show, Typeable, IsString, Monoid, NFData)+newtype Text1024 = Text1024 T.Text deriving(Eq, Data, Ord, Read, Show, Typeable, IsString, Monoid, NFData)+newtype Text2048 = Text2048 T.Text deriving(Eq, Data, Ord, Read, Show, Typeable, IsString, Monoid, NFData)+newtype Text4096 = Text4096 T.Text deriving(Eq, Data, Ord, Read, Show, Typeable, IsString, Monoid, NFData)++class TextConstraint a where+ txtConstraint :: T.Text -> a+ getTxt :: a -> T.Text++instance TextConstraint Text128 where txtConstraint = t128+ getTxt (Text128 t) = t+instance TextConstraint Text256 where txtConstraint = t256+ getTxt (Text256 t) = t+instance TextConstraint Text512 where txtConstraint = t512+ getTxt (Text512 t) = t+instance TextConstraint Text1024 where txtConstraint = t1024+ getTxt (Text1024 t) = t+instance TextConstraint Text2048 where txtConstraint = t2048+ getTxt (Text2048 t) = t+instance TextConstraint Text4096 where txtConstraint = t4096+ getTxt (Text4096 t) = t++instance (TextConstraint a) => TextConstraint (Maybe a) where+ txtConstraint t = Just $ txtConstraint t+ getTxt t = case t of+ Just a -> getTxt a+ Nothing -> T.empty++instance Hashable Text128 where hashWithSalt s d = hashWithSalt s (getTxt d)+instance Hashable Text256 where hashWithSalt s d = hashWithSalt s (getTxt d)+instance Hashable Text512 where hashWithSalt s d = hashWithSalt s (getTxt d)+instance Hashable Text1024 where hashWithSalt s d = hashWithSalt s (getTxt d)+instance Hashable Text2048 where hashWithSalt s d = hashWithSalt s (getTxt d)+instance Hashable Text4096 where hashWithSalt s d = hashWithSalt s (getTxt d)++instance Serialize Text128 where put (Text128 t) = put $ encodeUtf8 t+ get = (Text128 . decodeUtf8) `fmap` get+instance Serialize Text256 where put (Text256 t) = put $ encodeUtf8 t+ get = (Text256 . decodeUtf8) `fmap` get+instance Serialize Text512 where put (Text512 t) = put $ encodeUtf8 t+ get = (Text512 . decodeUtf8) `fmap` get+instance Serialize Text1024 where put (Text1024 t) = put $ encodeUtf8 t+ get = (Text1024 . decodeUtf8) `fmap` get+instance Serialize Text2048 where put (Text2048 t) = put $ encodeUtf8 t+ get = (Text2048 . decodeUtf8) `fmap` get+instance Serialize Text4096 where put (Text4096 t) = put $ encodeUtf8 t+ get = (Text4096 . decodeUtf8) `fmap` get++instance SafeCopy Text128 where putCopy (Text128 t) = putCopy t+ getCopy = contain $ Text128 `fmap` safeGet+instance SafeCopy Text256 where putCopy (Text256 t) = putCopy t+ getCopy = contain $ Text256 `fmap` safeGet+instance SafeCopy Text512 where putCopy (Text512 t) = putCopy t+ getCopy = contain $ Text512 `fmap` safeGet+instance SafeCopy Text1024 where putCopy (Text1024 t) = putCopy t+ getCopy = contain $ Text1024 `fmap` safeGet+instance SafeCopy Text2048 where putCopy (Text2048 t) = putCopy t+ getCopy = contain $ Text2048 `fmap` safeGet+instance SafeCopy Text4096 where putCopy (Text4096 t) = putCopy t+ getCopy = contain $ Text4096 `fmap` safeGet+++t128 :: T.Text -> Text128+t128 = Text128 . T.take 128++t256 :: T.Text -> Text256+t256 = Text256 . T.take 256++t512 :: T.Text -> Text512+t512 = Text512 . T.take 512 ++t1024 :: T.Text -> Text1024+t1024 = Text1024 . T.take 1024++t2048 :: T.Text -> Text2048+t2048 = Text2048 . T.take 2048++t4096 :: T.Text -> Text4096+t4096 = Text4096 . T.take 4096+
+ Keys/Random.hs view
@@ -0,0 +1,63 @@+module Keys.Random where+import Prelude+import System.Random.MWC+import Control.Monad+import Control.Monad.Primitive+import Data.ByteString as B+import Data.Word (Word8)+import Data.Text.Encoding+import Data.Text+import Keys.Constraints++{- | Converts a Char to a Word8. Took from MissingH -}+c2w8 :: Char -> Word8+c2w8 = fromIntegral . fromEnum++------------------------------------------------------------------------------+charRangeStart :: Word8+charRangeStart = c2w8 'a'++------------------------------------------------------------------------------+charRangeEnd :: Word8+charRangeEnd = c2w8 'z'++------------------------------------------------------------------------------+genString :: Gen (PrimState IO) -> IO B.ByteString+genString g = do+ randomLen <- uniformR (128 :: Int, 4096 :: Int) g+ str <- replicateM randomLen $ uniformR (charRangeStart, charRangeEnd) g+ return $ B.pack str++genInt :: Gen (PrimState IO) -> IO Int+genInt g = uniform g+genIntRange :: (Int, Int) -> Gen (PrimState IO) -> IO Int+genIntRange r g = uniformR r g++rndTxt :: IO Text+rndTxt = withSystemRandom genString >>= return . decodeUtf8++rndInt :: IO Int+rndInt = withSystemRandom genInt++rndIntRange :: (Int, Int) -> IO Int+rndIntRange r = withSystemRandom (genIntRange r)++class HasRandom a where+ rnd :: IO a++instance HasRandom Text where+ rnd = rndTxt++instance HasRandom B.ByteString where+ rnd = withSystemRandom genString++instance (HasRandom a) => HasRandom (Maybe a) where+ rnd = Just `fmap` rnd++instance HasRandom Text128 where rnd = txtConstraint `fmap` rndTxt+instance HasRandom Text256 where rnd = txtConstraint `fmap` rndTxt+instance HasRandom Text512 where rnd = txtConstraint `fmap` rndTxt+instance HasRandom Text1024 where rnd = txtConstraint `fmap` rndTxt+instance HasRandom Text2048 where rnd = txtConstraint `fmap` rndTxt+instance HasRandom Text4096 where rnd = txtConstraint `fmap` rndTxt+
+ Keys/UUID.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell, DeriveDataTypeable, TypeFamilies, GeneralizedNewtypeDeriving #-}+module Keys.UUID where++import Prelude+import Data.UUID (fromString, toString, toWords, fromWords)+import qualified Data.UUID as U (UUID, nil)+import Data.UUID.V4(nextRandom)+import Control.Applicative ((<$>))+-- import Data.Aeson.Types (FromJSON(..), ToJSON(..), typeMismatch)+-- import qualified Data.Aeson.Types as Aeson (Value(String))+-- import Data.Text.Encoding (encodeUtf8, decodeUtf8)+-- import Control.Monad(mzero)+import Data.Data+import Data.Hashable+import Data.Text (unpack, pack)+import Keys.Random+import Data.SafeCopy+import Data.Serialize+import Web.PathPieces+import Foreign.Storable+import Text.Blaze++newtype UUID = UUID U.UUID+ deriving(Ord, Eq, Data, Typeable, Storable)++instance Show UUID where+ show = strUUID+instance Read UUID where+ readsPrec x y = map (\(a,b) -> (UUID a, b)) $ readsPrec x y++unUUID :: UUID -> U.UUID+unUUID (UUID u) = u++strUUID :: UUID -> String+strUUID (UUID u) = toString u++nil :: UUID+nil = UUID U.nil++instance Serialize UUID where+ put (UUID u) = put $ toWords u+ get = (UUID . (\(w1,w2,w3,w4) -> fromWords w1 w2 w3 w4)) `fmap` get++instance HasRandom UUID where+ rnd = UUID `fmap` nextRandom++instance ToMarkup UUID where+ toMarkup u = toMarkup $ pack $ strUUID u++{- these can be useful in postgresql-simple:+instance FromField UUID where+ fromField f bs = + case bs of+ Nothing -> returnError UnexpectedNull f ""+ -- Parse the string values in the enum of sql/tableAuth.sql+ Just s -> case fromString . unpack . decodeUtf8 $ s of+ Just uuid -> pure $ UUID $ uuid+ Nothing -> returnError ConversionFailed f $ + "UUID must be a 16 bytes long ByteString in network byte order. Input UUID was: " ++ + (unpack (decodeUtf8 s))+instance ToField UUID where+ toField (UUID u) = Escape . encodeUtf8 . pack . toString $ u+ -}++instance Hashable UUID where+ hashWithSalt i (UUID u) = hashWithSalt i (toWords u)++instance SafeCopy UUID where+ putCopy (UUID u) = contain $ safePut $ toWords u+ getCopy = contain $ (UUID . (\(a,b,c,d) -> fromWords a b c d) <$> safeGet)++instance PathPiece UUID where+ -- fromPathPiece :: Text -> Maybe s+ fromPathPiece t = UUID <$> (fromString $ unpack t)+ -- toPathPiece :: s -> Text+ toPathPiece (UUID u) = pack $ toString u+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Hugo Gomes++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Hugo Gomes nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ special-keys.cabal view
@@ -0,0 +1,29 @@+name: special-keys+version: 0.1.0.0+synopsis: Simple data types that help me here and there. +description: Datatypes that I use as keys to index other data types. Here you will find a wrap of UUID and also constraints on Text so that it never exceeds a given number of characters.+license: BSD3+license-file: LICENSE+author: Hugo Gomes+maintainer: mr.hugo.gomes@gmail.com+-- copyright: +category: Data+build-type: Simple+cabal-version: >=1.8++library+ exposed-modules: Keys.UUID,+ Keys.Constraints,+ Keys.Random++ -- other-modules: + build-depends: base >= 4 && < 5,+ hashable >= 1.2,+ text >= 0.11,+ safecopy >= 0.8,+ cereal >= 0.3,+ path-pieces >= 0.1,+ blaze-markup >= 0.5,+ deepseq >= 1.3,+ primitive >= 0.5,+ bytestring >= 0.10