src/Gargantext/Prelude/Crypto/Pass/Machine.hs

   1 {-|
   2 Module      : Gargantext.Prelude.Crypto.Pass.Machine
   3 Description :
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : Public Domain
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Random Text generator (for machines mainly)
  11
  12 Thanks to
  13 https://zuttobenkyou.wordpress.com/2011/12/23/simple-password-generation-with-haskell/
  14
  15 -}
  16
  17
  18 module Gargantext.Prelude.Crypto.Pass.Machine
  19       where
  20
  21 import Data.List (nub)
  22 -- import System.Environment (getArgs)
  23 -- import System.IO (hSetEcho)
  24 import Data.Text (Text)
  25 import Control.Monad.State
  26 import Crypto.Random (cprgGenerate)
  27 import Crypto.Random.AESCtr
  28 import Data.Binary (decode)
  29 import Prelude
  30 import qualified Data.ByteString.Lazy as B
  31 import Gargantext.Prelude (cs)
  32 import Data.ByteString as S (ByteString, unpack)
  33 import Data.ByteString.Char8 as C8 (pack)
  34 import Data.Char (chr)
  35
  36 strToBS :: String -> S.ByteString
  37 strToBS = C8.pack
  38
  39 bsToStr :: S.ByteString -> String
  40 bsToStr = map (chr . fromEnum) . S.unpack
  41
  42
  43 keysChar, keysNum, keysPunc, keysCharNum, keysAll, keysHex :: String
  44 keysChar = ['a'..'z'] ++ ['A'..'Z']
  45 keysHex = ['a'..'f']
  46 keysNum = ['0'..'9']
  47 keysPunc = "`~!@#$%^&*()-_=+[{]}\\|;:'\",<.>/? "
  48 keysCharNum = keysChar ++ keysNum
  49 keysAll = keysChar ++ keysNum ++ keysPunc
  50
  51 giveKey ::  String -> Char -> Int -> Char
  52 giveKey keysCustom c n = extractChar $ case c of
  53     'i'  -> (keysNum ++ keysHex)
  54     'j'  -> keysNum
  55     'k'  -> keysChar
  56     'l'  -> keysCharNum
  57     ';'  -> keysPunc
  58     'h'  -> (keysCharNum ++ keysCustom)
  59     '\n' -> ['\n']
  60     _    -> keysAll
  61     where
  62     extractChar xs = xs!!mod n (length xs)
  63
  64 showRandomKey :: Int -> String -> StateT AESRNG IO ()
  65 showRandomKey len keysCustom = handleKey =<< liftIO getChar
  66     where
  67     handleKey key = case key of
  68         '\n' -> liftIO (putChar '\n') >> showRandomKey len keysCustom
  69         'q' -> (liftIO $ putStrLn "\nBye!") >> return ()
  70         _ -> mapM_ f [0..len] >> (liftIO $ putStrLn []) >> showRandomKey len keysCustom
  71         where
  72         f _ = liftIO
  73             . putChar
  74             . giveKey keysCustom key
  75             . (\n -> mod n (length (keysAll ++ keysCustom) - 1))
  76             =<< aesRandomInt
  77
  78
  79 aesRandomInt :: StateT AESRNG IO Int
  80 aesRandomInt = do
  81     aesState <- get
  82     -- aesState <- liftIO makeSystem
  83     -- let aesState = 128
  84     let (bs, aesState') = cprgGenerate 64 aesState
  85     put aesState'
  86     return (decode $ B.fromChunks [bs])
  87
  88 printPass :: Int -> IO ()
  89 printPass len = do
  90   let as = ["alphanumeric","punctuation"]
  91   let as' = filter (\c -> elem c keysAll) . nub $ unwords as
  92   aesState <- makeSystem -- gather entropy from the system to use as the initial seed
  93   _ <- runStateT (showRandomKey len as') aesState -- enter loop
  94   return ()
  95
  96 gargPassMachine :: IO (Int, AESRNG)
  97 gargPassMachine = do
  98   aesState <- makeSystem -- gather entropy from the system to use as the initial seed
  99   pass <- runStateT aesRandomInt aesState -- enter loop
 100   pure pass
 101
 102
 103 {-
 104 main :: IO ()
 105 main = do
 106     hSetBuffering stdin NoBuffering  -- disable buffering from STDIN
 107     hSetBuffering stdout NoBuffering -- disable buffering from STDOUT
 108     hSetEcho stdin False             -- disable terminal echo
 109     as <- getArgs
 110     let as' = filter (\c -> elem c keysAll) . nub $ unwords as
 111     mapM_ putStrLn
 112         [ []
 113         , "poke: 'q'     quit"
 114         , "      'j'     number"
 115         , "      'k'     letter"
 116         , "      'l'     alphanumeric"
 117         , "      ';'     punctuation"
 118         , "      'h'     alphanumeric" ++ (if null as' then [] else " + " ++ as')
 119         , "      'i'     hexadecimal"
 120         , "      'ENTER' newline"
 121         , "      else    any"
 122         , []
 123         ]
 124     aesState <- makeSystem -- gather entropy from the system to use as the initial seed
 125     _ <- runStateT (showRandomKey as') aesState -- enter loop
 126     return ()
 127 -}