src/Gargantext/Prelude/Crypto/Pass.hs

   1 {-|
   2 Module      : Gargantext.Prelude.Crypto.Pass
   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 To avoid weak password, just offer an easy way to make "good" one and
  11 let user add his own entropy.
  12
  13 Thanks to
  14 https://zuttobenkyou.wordpress.com/2011/12/23/simple-password-generation-with-haskell/
  15
  16 -}
  17
  18
  19 module Gargantext.Prelude.Crypto.Pass
  20       where
  21
  22 -- import Data.List (nub)
  23 -- import System.Environment (getArgs)
  24 -- import System.IO (hSetEcho)
  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
  32
  33 keysChar, keysNum, keysPunc, keysCharNum, keysAll, keysHex :: String
  34 keysChar = ['a'..'z'] ++ ['A'..'Z']
  35 keysHex = ['a'..'f']
  36 keysNum = ['0'..'9']
  37 keysPunc = "`~!@#$%^&*()-_=+[{]}\\|;:'\",<.>/? "
  38 keysCharNum = keysChar ++ keysNum
  39 keysAll = keysChar ++ keysNum ++ keysPunc
  40
  41 giveKey ::  String -> Char -> Int -> Char
  42 giveKey keysCustom c n = extractChar $ case c of
  43     'i'  -> (keysNum ++ keysHex)
  44     'j'  -> keysNum
  45     'k'  -> keysChar
  46     'l'  -> keysCharNum
  47     ';'  -> keysPunc
  48     'h'  -> (keysCharNum ++ keysCustom)
  49     '\n' -> ['\n']
  50     _    -> keysAll
  51     where
  52     extractChar xs = xs!!mod n (length xs)
  53
  54 showRandomKey :: Int -> String -> StateT AESRNG IO ()
  55 showRandomKey len keysCustom = handleKey =<< liftIO getChar
  56     where
  57     handleKey key = case key of
  58         '\n' -> liftIO (putChar '\n') >> showRandomKey len keysCustom
  59         'q' -> (liftIO $ putStrLn "\nBye!") >> return ()
  60         _ -> mapM_ f [0..len] >> (liftIO $ putStrLn []) >> showRandomKey len keysCustom
  61         where
  62         f _ = liftIO
  63             . putChar
  64             . giveKey keysCustom key
  65             . (\n -> mod n (length (keysAll ++ keysCustom) - 1))
  66             =<< aesRandomInt
  67
  68 aesRandomInt :: StateT AESRNG IO Int
  69 aesRandomInt = do
  70     aesState <- get
  71     -- aesState <- liftIO makeSystem
  72     -- let aesState = 128
  73     let (bs, aesState') = cprgGenerate 64 aesState
  74     put aesState'
  75     return (decode $ B.fromChunks [bs])
  76
  77 gargPass :: IO (Int, AESRNG)
  78 gargPass = do
  79   -- let as = ["alphanumeric","punctuation"]
  80   -- let as' = filter (\c -> elem c keysAll) . nub $ unwords as
  81   aesState <- makeSystem -- gather entropy from the system to use as the initial seed
  82   --_ <- runStateT (showRandomKey len as') aesState -- enter loop
  83   -- return ()
  84   pass <- runStateT aesRandomInt aesState -- enter loop
  85   pure pass
  86
  87 {-
  88 main :: IO ()
  89 main = do
  90     hSetBuffering stdin NoBuffering  -- disable buffering from STDIN
  91     hSetBuffering stdout NoBuffering -- disable buffering from STDOUT
  92     hSetEcho stdin False             -- disable terminal echo
  93     as <- getArgs
  94     let as' = filter (\c -> elem c keysAll) . nub $ unwords as
  95     mapM_ putStrLn
  96         [ []
  97         , "poke: 'q'     quit"
  98         , "      'j'     number"
  99         , "      'k'     letter"
 100         , "      'l'     alphanumeric"
 101         , "      ';'     punctuation"
 102         , "      'h'     alphanumeric" ++ (if null as' then [] else " + " ++ as')
 103         , "      'i'     hexadecimal"
 104         , "      'ENTER' newline"
 105         , "      else    any"
 106         , []
 107         ]
 108     aesState <- makeSystem -- gather entropy from the system to use as the initial seed
 109     _ <- runStateT (showRandomKey as') aesState -- enter loop
 110     return ()
 111 -}